perm filename LIBPAS.OLD[PAS,SYS]1 blob sn#470634 filedate 1979-08-31 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00039 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00005 00002	(*$E+,S1200,T-
C00010 00003	PROGRAM ccl, option, getoption, getfilename, askfilename, startfile, getparameter, getnextcall, reenter
C00015 00004	TYPE
C00019 00005		(** ENTER ENTER_SWITCH **)
C00021 00006		(** GETFILENAME RE_INITIALIZE INITIALIZE READCHAR READOCTAL READDECIMAL SETSTATUS READSWITCH OPERAND NEXTCH ASSIGNFILENAMEOREXTENSION **)
C00035 00007		(** GETPARAMETER ASKFILENAME STARTFILE INITIALIZE **)
C00046 00008		(** OPTION FIND_SWITCH GETOPTION PICTURE **)
C00053 00009	PROGRAM ddt, debug
C00064 00010	VAR
C00068 00011		(** DEBUG [ SYSTEM_ERROR ERROR NEWLINE LENGTH **)
C00070 00012		(** INSYMBOL NEXTCH **)
C00079 00013		(** ACRPOINT TESTGLOBALBASIS IDTREE FIRSTBASIS SUCCBASIS SEARCHSECTION SEARCHID **)
C00083 00014		(** GETBOUNDS COMPTYPES **)
C00088 00015		(** NEXTBYTE PUTNEXTBYTE **)
C00090 00016		(** LOAD GETFIELD SELECTOR **)
C00098 00017		(** VARIABLE **)
C00101 00018		(** EXPRESSION SIMPLEEXPRESSION TERM FACTOR **)
C00106 00019		(** SHIFTED_OUT WRITESCALAR PUTSIXBIT **)
C00111 00020		(** WRITESTRUCTURE WRITEFIELDLIST **)
C00126 00021		(** ASSIGNMENT **)
C00128 00022		(** STOPSEARCH PAGEVALUE LINEVALUE BREAKPOINT GETLINPAG **)
C00136 00023		(** LINEINTERVAL STOPMESSAGE TRACEOUT ONE_VAR_OUT **)
C00140 00024		(** SECTION_OUT OUT **)
C00145 00025		(** STACK_OUT HEAP_OUT **)
C00149 00026		(** WRITE_PROGRAM_NAME HEADER BACK_TO_TTY CORRECT_ADDR RIGHT_ADDR **)
C00153 00027		(** INIT DEBUG_INTERACTIVE **)
C00160 00028		(** DEBUG_BATCH ] DEBUG **)
C00163 00029	PROGRAM status, getstatus
C00166 00030	PROGRAM read, readscalar, readirange,
C00173 00031		(** STOP ERROR NEXTCH SKIP READIRANGE READCRANGE READRRANGE **)
C00179 00032		(** READSCALAR READIDENTIFIER READSET **)
C00188 00033		(** READISET READCSET READDSET **)
C00193 00034	PROGRAM write, wrtscalar, wrtiset, wrtcset, wrtdset
C00196 00035		(** WRTSCALAR WRTSET WRTISET WRTCSET WRTDSET **)
C00201 00036	PROGRAM timing, setruntime, setelapsedtime, settime, runtime, elapsedtime,
C00207 00037	PROGRAM strings, assign, length, pos, substr, concat, getchar, putchar,
C00229 00038	PROGRAM dumper, dpcnts
C00233 00039	PROGRAM mathruns, psqrt
C00235 ENDMK
C⊗;
(*$E+,S1200,T-

 PASCAL RUNTIME PROGRAM LIBRARY (ARMANDO RODRIGUEZ, SEPT-78)
 DERIVED FROM (KISICKI,24-AUG-76)

 DICTIONARY:

 PAGE1   :      DICTIONARY
 PAGE2   :      CCL             HIGHLY MODIFIED VERSION
 PAGE3   :      DDT
 PAGE4   :      STATUS
 PAGE5   :      READ            HIGHLY MODIFIED VERSION
 PAGE6   :      WRITE
 PAGE7   :      TIMING          FOR PASSGO-GENERATED PROGRAMS.
 PAGE8   :      STRINGS         NON-STANDARD 'STRING' PACKAGE.
 PAGE9   :      DUMPER          FOR STATMENT COUNTS (/PROFILE SWITCH)
 PAGE10  :      MATHRUN         TO GIVE ERRORS ON CALLS TO FTN ROUTINES.

note: compiling this source with the switch (or compile option) VERSION:
	1: For everybody's use.
	3: Local for PASCAL and PASSGO at Stanford Artificial Intelligence Lab.

 *)

PROGRAM ccl, option, getoption, getfilename, askfilename, startfile, getparameter, getnextcall, reenter;

    (******************************************************************************************
     *
     *
     *  (C) COPYRIGHT 1978, 1979
     *          BOARD OF TRUSTEES
     *          LELAND STANFORD JUNIOR UNIVERSITY
     *              STANFORD, CA. 94305, U. S. A.
     *
     *      (C) COPYRIGHT 1978, 1979
     *          ARMANDO R. RODRIGUEZ
     *              LOTS COMPUTER FACILITY
     *              STANFORD UNIVERSITY
     *              STANFORD, CA. 94305, U. S. A.
     *
     *   (C) COPYRIGHT H.-H. NAGEL
     *                 INSTITUT FUER INFORMATIK
     *                 DER UNIVERSITAET HAMBURG
     *                 SCHLUETERSTRASSE 70
     *                 2000 HAMBURG 13
     *                 GERMANY
     *                 1976
     *
     *
     *    PASCAL RUNTIME SYSTEM (29-JUL-76,KISICKI)
     *
     *    DECSYSTEM-10 CONCISE COMMAND LANGUAGE INTERFACE
     *
     *     PASCAL RUNTIME-SUPPORTS:        GETPARAMETER
     *
     *     PRE-DECLARED FUNCTIONS:         OPTION
     *
     *     PRE-DECLARED PROCEDURES:        GETOPTION,
     *                                     GETFILENAME
     *
     *    MODIFIED 1-APR-1978 BY ARMANDO R. RODRIGUEZ, STANFORD UNIVERSITY
     *            +  SWITCHES CAN TAKE NEGATIVE AND ALPHABETIC VALUES.
     *            +  GETPARAMETER WAS BROKEN INTO ASKFILENAME AND STARTFILE
     *                TO ALLOW THEIR USE BY USER PROGRAMS.
     *
     *    MODIFIED 13-JUL-1978 BY ARMANDO R. RODRIGUEZ, STANFORD UNIVERSITY
     *            +  TAKE IN A SECOND LINE THE NAME OF A PROGRAM TO BE CALLED NEXT.
     *
     *    MODIFIED 18-AUG-1978 BY ARMANDO R. RODRIGUEZ, STANFORD UNIVERSITY
     *            +  ADD THE PROCEDURE REENTER, TO RESET WHAT IS SET IN THE
     *                  INITPROCEDURE, TO ALLOW FOR RESTARTABLE PASCAL PROGRAMS.
     *
     *    DEFINITIONS:
     *
     *    <FILE SPECIFICATION> ::= <EMPTY> OR <FILENAME> OR
     *     <DEVICE>:<FILENAME>.<EXTENSION>[<PROJECT>,<PROGRAMMER>]<<PROTECTION>>
     *     (<SWITCH>/.../<SWITCH>)
     *     /<SWITCH>.../<SWITCH>
     *
     *    <PROGRAMNAME>, <DEVICE>, <FILENAME>, <EXTENSION> ::= <IDENTIFIER>
     *    <PROJECT>, <PROGRAMMER>, <PROTECTION> ::= <UNSIGNED OCTAL NUMBER>
     *    <SWITCH> ::= <IDENTIFIER> OR <IDENTIFIER>:<VALUE>
     *    <VALUE>  ::= <DECIMAL NUMBER> OR <LETTER>
     *
     ****************************************************************************************)

TYPE
    anyfile = FILE OF integer;
    pack9 = PACKED ARRAY[1..9] OF char;
    pack7 = PACKED ARRAY[1..7] OF char;
    pack6 = PACKED ARRAY[1..6] OF char;
    pack5 = PACKED ARRAY[1..5] OF char;
    pack3 = PACKED ARRAY[1..3] OF char;
    source_form = (tempfile,teletypeoutput,teletypeinput,teletype);
    delimiter = (blank,lparent,rparent,comma,point,slash,less,equal,greater,rbrack,lbrack,colon,exclamation,unknown);
    swp = ↑switch_descriptor;
    switch_descriptor = PACKED RECORD
				   name: alfa;
				   left, right: swp;
				   value: integer
			       END;

VAR
    callcnt, prot_old, ufd_old: integer;
    programname: alfa;
    tmp_filename, file_old: pack9;
    source: source_form;
    fromtmpfile,
    end_of_filename, defaulted, error, usercall: boolean;
    breakchar,
    lastch: char;
    device_old: pack6;
    next_name,
    filename: pack9;
    next_device,
    device: pack6;
    current_switch, new_switch, switch_tree: swp;
    delimiter1:  ARRAY[' '..'/'] OF delimiter;
    delimiter2:  ARRAY[':'..'>'] OF delimiter;
    delimiter3:  ARRAY['['..']'] OF delimiter;

INITPROCEDURE;
    BEGIN
    source := tempfile; callcnt := 0; usercall := true; error := false;
    defaulted := true; lastch := ' ';

    tmp_filename := '      TMP';
    next_name := '         ';
    next_device := '      ';
    switch_tree := NIL; current_switch := NIL;
    delimiter1[' '] := blank;             delimiter1['!'] := exclamation;
    delimiter1['('] := lparent;           delimiter1[')'] := rparent;
    delimiter1[','] := comma;             delimiter1['.'] := point;
    delimiter1['/'] := slash;
    delimiter2[':'] := colon;             delimiter2['<'] := less;
    delimiter2['='] := equal;             delimiter2['>'] := greater;
    delimiter3['['] := lbrack;            delimiter3[']'] := rbrack;
    END;

PROCEDURE reenter;      (* ADDED TO ALLOW FOR RESTART OF PASCAL PROGRAMS*)
    BEGIN  (* REENTER *)
    source := tempfile; callcnt := 0; usercall := true; error := false;
    defaulted := true; lastch := ' ';

    tmp_filename := '      TMP';
    next_name := '         ';
    next_device := '      ';
    switch_tree := NIL; current_switch := NIL;
    END (* REENTER *);

	(** ENTER ENTER_SWITCH **)

PROCEDURE enter(fname: alfa; fvalue: integer);

    PROCEDURE enter_switch(ftree: swp);
	BEGIN
	WITH ftree↑ DO
	    IF new_switch↑.name <> name THEN
		IF new_switch↑.name < name THEN
		    IF left = NIL THEN left := new_switch
		    ELSE enter_switch(left)
		ELSE
		    IF right = NIL THEN right := new_switch
		    ELSE enter_switch(right)
	END (* ENTER_SWITCH *);

    BEGIN (* ENTER *)
    new(new_switch);
    WITH new_switch↑ DO
	BEGIN
	name := fname; value := fvalue;
	left := NIL  ; right := NIL
	END;
    IF switch_tree = NIL THEN switch_tree := new_switch
    ELSE enter_switch(switch_tree)
    END (* ENTER *);
	(** GETFILENAME RE_INITIALIZE INITIALIZE READCHAR READOCTAL READDECIMAL SETSTATUS READSWITCH OPERAND NEXTCH ASSIGNFILENAMEOREXTENSION **)

    (**********************************************************************
     *
     *   PROCEDURE GETFILENAME
     *
     *    - READ DECSYSTEM-10 <FILE SPECIFICATION> FROM
     *      "SOURCEFILE".
     *
     *      GETFILENAME IS A PRE-DECLARED PROCEDURE
     *      AND AVAILABLE TO EVERY PASCAL USER.
     *
     **********************************************************************)

PROCEDURE getfilename(VAR sourcefile: text;
		      VAR filename: pack9;
		      VAR protection,ufd: integer;
		      VAR device: pack6;
		      filevariable: alfa);
    VAR
	buffer: alfa;
	i, j, k, imax, ocval, sign, source_prot, source_ppn: integer;
	source_fil: PACKED ARRAY[1..9] OF char;
	source_dev: PACKED ARRAY[1..6] OF char;
	ch,status: char;
	new_status: boolean;

    PROCEDURE re_initialize;
	BEGIN
	i := 0; buffer := '          '; ocval := 0; sign :=1;
	new_status := false;
	END (* RE_INITIALIZE *);

    PROCEDURE initialize;
	BEGIN
	filename := '         '; device := 'DSK   '; status := ' '; imax := 6;
	ch := ' '; ufd := 0; protection := 0; error := false; end_of_filename := false;
	re_initialize; defaulted := true
	END (* INITIALIZE *);

    FUNCTION picture(fch: char): delimiter;
	BEGIN
	IF fch IN [' ','!','(',')',',','.','/',':','<','=','>','[',']'] THEN
	    IF fch <= '/' THEN picture := delimiter1[fch]
	    ELSE
		IF fch <= '>' THEN picture := delimiter2[fch]
		ELSE picture := delimiter3[fch]
	ELSE picture := unknown;
	END (* PICTURE *);

    PROCEDURE readchar;
	BEGIN
	i := i + 1;
	IF i > imax THEN error := true
	ELSE buffer[i] := ch
	END (*READCHAR*) ;

    PROCEDURE readoctal;
	BEGIN
	IF ch IN ['0'..'7'] THEN
	    BEGIN
	    ocval := ocval * 10B + ord(ch) - ord('0')
	    END
	ELSE error := true
	END (*READOCTAL*) ;

    %34
    procedure readsixbit;
	begin
	if ch in [' '..'_'] then
	    begin
	    ocval := ocval * 100B + (ord(ch) - ord(' '));
	    end
	else
	    error := true;
	end (*readsixbit*);
    \

    PROCEDURE readdecimal;
	BEGIN
	IF ch IN ['0'..'9'] THEN
	    BEGIN
	    ocval := ocval * 10 + ord(ch) - ord('0')
	    END
	ELSE
	    IF ocval = 0 THEN
		IF ch IN ['A'..'Z'] THEN
		    ocval:=ord(ch)
		ELSE
		    IF ch = '-' THEN
			sign:=-1
		    ELSE
			error := true
	    ELSE
		error := true;
	END (*READDECIMAL*) ;

    PROCEDURE setstatus;
	BEGIN
	IF ch <> ' ' THEN
	    BEGIN
	    CASE picture(ch) OF
		colon        :
			    error := status <> ' ';
		point        :
			    error := NOT (status IN [' ',':']);
		lbrack       :
			    error := NOT (status IN [' ',':','.']);
		less         :
			    error := NOT (status IN [' ',':','.',']']);
		comma        :
			    error := status <> '[';
		rbrack       :
			    error := status <> ',';
		greater      :
			    error := status <> '<';
		slash        :
			    error := NOT (status IN [' ',':','.',']','>',')']);
		lparent      :
			    error := NOT (status IN [' ',':','.',']','>']);
		rparent      :
			    error := status <> '(';
		OTHERS       :
			    error := true
		END;
	    IF NOT error THEN
		BEGIN
		new_status := true; status := ch
		END
	    END
	END (*SETSTATUS*) ;

    PROCEDURE readswitch;
	VAR
	    read_value, end_of_switch: boolean;
	BEGIN
	IF NOT eoln(sourcefile) THEN
	    BEGIN
	    REPEAT
		imax := alfalength;
		re_initialize;
		read_value := false;
		end_of_switch := false;
		LOOP
		    IF eoln(sourcefile) THEN
			BEGIN
			end_of_switch := true; ch := ' '
			END
		    ELSE 
			begin
			read(sourcefile,ch);
			%34  if ch = '_' then
				ch := '=';
			\
			end;
		    lastch := ch
		EXIT IF NOT (ch IN ['0'..'9',':','A'..'Z',' ','-']) OR end_of_switch;
		    IF ch <> ' ' THEN
			IF read_value THEN readdecimal
			ELSE
			    IF ch = ':' THEN read_value := true
			    ELSE readchar
		    END;
		IF i > 0 THEN enter(buffer,ocval*sign)
	    UNTIL NOT (ch IN ['/',',']) OR ((ch = ',') AND (status <> '(')) OR end_of_switch;
	    IF ch IN [',','=']THEN
		BEGIN
		end_of_filename := true; ch := ' '
		END;
	    setstatus
	    END
	END (* READSWITCH *);


    PROCEDURE operand;

	PROCEDURE nextch;
	    BEGIN
	    IF eoln(sourcefile) THEN
		%34 if status = ',' then
			ch := ']'
		    else
			\
		BEGIN
		end_of_filename := true;
		    ch := ' ';
		END
	    ELSE 
		begin
		read(sourcefile,ch);
		%34  if ch = '_' then
			ch := '=';
			\
		end;
	    lastch := ch;
	    IF end_of_filename OR ((ch=',') AND (status<>'[')) OR (ch='=') THEN
		BEGIN
		end_of_filename := true;
		CASE picture(status) OF
		    blank:
			ch := '.';
		    colon:
			ch := '.';
		    point:
			ch := '[';
		    rparent,
		    slash,
		    greater,
		    rbrack:
			 BEGIN
			 ch := ' '; status := ' '
			 END;
		    OTHERS:
			 BEGIN
			 error := true; ch := ' '
			 END
		    END
		END
	    END (*NEXTCH*) ;

	BEGIN
	(*OPERAND*)
	REPEAT
	    nextch;
	    IF ch IN ['A'..'Z','0'..'9'] THEN
		IF status IN ['[',',','<'] THEN
		    %34  if status <> '<' then
			    readsixbit
			 else
			\
		    readoctal
		ELSE readchar
	    ELSE setstatus
	UNTIL new_status OR error OR end_of_filename
	END (*OPERAND*) ;

    PROCEDURE assignfilenameorextension;
	BEGIN (*ASSIGNFILENAMEOREXTENSION*)
	IF i > 0 THEN
	    IF (filename[1] = ' ') OR ((filename[7] = ' ') AND (imax = 3)) THEN
		BEGIN
		IF imax = 3 THEN k := 6
		ELSE k := 0;
		FOR j := 1 TO imax DO filename[k+j] := buffer[j];
		END
	END (*ASSIGNFILENAMEOREXTENSION*);

	(***********************************************************************
	 *
	 *   PROCEDURE GETNEXTPROCESSOR
	 *
	 *    _ READ THE SECOND LINE OF A TOPS-20 CCL FILE.
	 *
	 *      <FILENAME>!
	 *
	 *      WHERE FILENAME IS A NAME OF A PROGRAN TO BE RUN AFTER PASCAL
	 *
	 ***********************************************************************)


    PROCEDURE getnextprocessor;
	VAR
	    token: pack7;
	    brkchar: char;

	PROCEDURE gettoken(VAR token: pack7;
			   VAR brkch: char);
	    BEGIN
	    i := 1; token := '       ';
	    read(sourcefile,ch);
	    WHILE NOT (ch IN [':','.','!']) AND NOT eoln(sourcefile) AND (i <= 7) DO
		BEGIN
		token[i] := ch;
		read(sourcefile,ch); i := i + 1;
		END;
	    IF ch IN [':','.','!'] THEN
		brkch := ch
	    ELSE
		brkch := ' ';
	    END (* GETTOKEN *);

	BEGIN (* GETNEXTPROCESSOR *)
	gettoken(token, brkchar);
	IF brkchar = ':' THEN
	    BEGIN
	    FOR i:=1 TO 6 DO
		next_device[i] := token[i];
	    gettoken (token, brkchar);
	    END
	ELSE
	    next_device  := 'DSK   ';

	IF brkchar IN ['.', '!'] THEN
	    BEGIN
	    FOR i:=1 TO 6 DO
		next_name[i] := token[i];
	    IF brkchar = '.' THEN	    (* SKIP EXTENSION *)
		gettoken(token, brkchar);
	    IF brkchar <> '!' (* LINE NOT TERMINATING CORRECTLY *) THEN
		next_name := '         ';
	    END
	ELSE
	    next_name := '         ';
	END (* GETNEXTPROCESSOR *);


    BEGIN  (*GETFILENAME*)
    LOOP
	IF usercall THEN
	    BEGIN
	    getstatus(sourcefile, source_fil, source_prot, source_ppn, source_dev);
	    IF source_dev = 'TTY   ' THEN
		BEGIN
		write(tty,cr,lf,filevariable,'= ');
		break(tty);
		readln(sourcefile)
		END
	    END;
	initialize;
	IF NOT eof(sourcefile) THEN
	    IF NOT eoln(sourcefile) THEN
		REPEAT
		    operand;
		    IF NOT error THEN
			BEGIN
			CASE picture(status) OF
			    colon:
				IF i > 0 THEN BEGIN
				    device := '      ' ;
				    FOR j := 1 TO i DO device[j] := buffer[j];
				    END ;
			    point:
				BEGIN
				assignfilenameorextension; imax := 3
				END;
			    less,
			    lbrack:
				 assignfilenameorextension;
			    lparent,
			    slash:
				BEGIN
				assignfilenameorextension; readswitch
				END;
			    comma :
				%34  if ocval >= 400000B then
					ufd := (ocval - 400000B) * 1000000B + 400000000000B
				     else
					\
				 ufd := ocval * 1000000B;
			    rbrack :
				  ufd := ufd + ocval;
			    greater :
				   protection := ocval
			    END;
			re_initialize; defaulted := false
			END
		UNTIL error OR end_of_filename;
	defaulted := (filename[1] = ' ') AND (device = 'DSK   ');
	IF NOT defaulted THEN
	    IF NOT error AND eoln(sourcefile) AND (pred(source) = tempfile) AND NOT eof(sourcefile) THEN
		BEGIN
		readln(sourcefile);
		status := ' ';
		ch := ' ';
		IF NOT eoln (sourcefile) THEN
		    begin
		    lastch := ' ';
		    getnextprocessor;
		    end;
		END;
    EXIT IF NOT (error AND usercall);
	writeln(tty,'%? SYNTAX ERROR: REENTER'); break(tty);
	END;
    usercall := true;
    END (*GETFILENAME*);
	(** GETPARAMETER ASKFILENAME STARTFILE INITIALIZE **)

    (**********************************************************************
     *
     *   PROCEDURE GETPARAMETER
     *
     *    - READ A DECSYSTEM-10 <FILE SPECIFICATION> FROM EITHER
     *
     *       * A TEMPCORE-FILE NAMED <1ST 3 CHARS. OF PROGRAMNAME>.TMP,
     *         CREATED BY DECSYSTEM-10 COMPIL-CLASS COMMANDS OR USER, OR
     *
     *       * TTY
     *
     *      ALL FILES HAVE TO BE "TEXT"-FILES.
     *
     *      TEMPCORE-FILES CAN BE ACCESSED AND CREATED AUTOMATICALLY
     *      BY PASCAL PROGRAMS IF THE FILENAME IS SPECIFIED AS
     *      'XXX   TMP' AND DEVICE IS 'DSK   ', WHERE XXX ARE
     *      THE 1ST 3 CHARACTERS OF THE <PROGRAMNAME>. IF THE TEMPCORE-FILE
     *      CANNOT BE FOUND/CREATED THE DISK-FILE 'NNNXXXTMP' IS
     *      SEARCHED/CREATED, WHERE NNN IS THE JOB-NUMBER.
     *
     *    - GETPARAMETER IS PART OF THE PASREL RUNTIME-SUPPORT.
     *      A CALL OF GETPARAMETER IS GENERATED BY THE PASREL COMPILER
     *      FOR EACH PARAMETER SPECIFIED IN THE <PROGRAM HEADING>.
     *
     *      ASKFILENAME AND STARTFILE CONTAIN WHAT ORIGINALLY WAS GETPARAMETER,
     *          BROKEN IN TWO PARTS SO THAT YOU CAN SUPRESS OPPENING OF
     *          THE FILE (STARTFILE) IF DESIRED SO. THEY ARE BOTH PRE-DECLARED
     *          PROCEDURES, AND AVAILABLE TO EVERY PASCAL USER.
     *          (CHANGE MADE AT LOTS, STANFORD UNIVERSITY, BY ARMANDO
     *          RODRIGUEZ, 1-APR-1978).
     *
     *      THE INPUT FORMAT IS FOR
     *
     *       * TEMPCORE-FILES:
     *
     *          <FILE SPECIFICATION>,...,<FILE SPECIFICATION>/<SWITCH>.../<SWITCH><CR><LF>
     *          <DEVICE>:<FILENAME>!<CR><LF>
     *
     *          THE SECOND LINE (USED BY COMPIL-CLASS COMMANDS) IS OPTIONAL
     *
     *       * TTY:
     *
     *          <FILE SPECIFICATION><CR><LF>
     *
     ***********************************************************************)


PROCEDURE initialize;
    VAR
	i: integer;
    BEGIN
    IF source <> teletype THEN
	BEGIN
	CASE source OF
	    tempfile:
		   BEGIN
		   FOR i := 1 TO 3 DO tmp_filename[i] := programname[i];
		   reset(tty,tmp_filename,0,0,'DSK   ')
		   END;
	    teletypeoutput:
			 rewrite(tty,'TTYOUTPUT');
	    teletypeinput:
			reset(tty,'TTY      ',0,0,'TTY   ')
	    END;
	source := succ(source);
	IF eof(tty) AND NOT (source IN [teletypeinput,teletype]) THEN initialize;
	END
    END (* INITIALIZE *);

PROCEDURE askfilename(VAR filename: pack9;
		      VAR protection,ufd: integer;
		      VAR device: pack6;
		      fileident,progname: alfa;
		      inputfile: boolean;
		      VAR fromtmpfile: boolean;
		      var breakchar: char);

    BEGIN (*ASKFILENAME*)
    programname:=progname;
    IF callcnt = 0 THEN
	initialize;
    callcnt := callcnt + 1;

    LOOP

	IF source IN [teletype,teletypeinput] THEN
	    BEGIN
	    write(tty,fileident,'= ');break(tty);
	    IF source = teletypeinput THEN initialize
	    ELSE readln(tty)
	    END;

	usercall := false;
	getfilename(tty,filename,protection,ufd,device,'          ');
	IF device = 'LPT   ' THEN enter('LPT       ',0) ;

	error := (inputfile AND NOT defaulted AND (device = 'LPT   ')) OR error;
    EXIT IF NOT error;
	IF source <> teletype THEN
	    BEGIN
	    source := teletypeoutput; initialize
	    END;
	writeln(tty,'%? SYNTAX ERROR: REENTER');
	break(tty);
	END;
    fromtmpfile := pred(source) = tempfile;
    breakchar := lastch;
    enD (*ASKFILENAME*);

PROCEDURE startfile(VAR currentfile: anyfile;
		    VAR filename: pack9;
		    VAR protection,ufd: integer;
		    VAR device: pack6;
		    inputfile: boolean;
		    fileident: alfa;
		    defaultext: pack3);
    VAR
	i: integer;
	extdefaulted: boolean;
	tempfile: pack9;

    BEGIN (*STARTFILE*)
    IF usercall = true THEN
	BEGIN
	defaulted:=(filename='         ') AND (device = 'DSK   ');
	source:=teletype;
	FOR i:=1 TO 9 DO
	    file_old[i]:=fileident[i];
	prot_old:=0;
	ufd_old:=0;
	device_old:='DSK   ';
	extdefaulted := (filename[7] = ' ') AND (defaultext[1] <> ' ');
	END
    ELSE
	extdefaulted := false;
    error:=false;

    LOOP

	IF NOT error THEN
	    IF defaulted THEN
		IF inputfile THEN
		    BEGIN
		    IF device_old = 'TTY   ' THEN
			BEGIN
			write(tty,'TO CONTINUE, HIT THE RETURN KEY *');
			break(tty);
			END;
		    reset(currentfile,file_old,prot_old,ufd_old,device_old)
		    END
		ELSE
		    rewrite(currentfile,file_old,prot_old,ufd_old,device_old)
	    ELSE
		BEGIN
		IF extdefaulted THEN
		    BEGIN
		    tempfile := filename;
		    FOR i := 1 TO 3 DO
			filename[i + 6] := defaultext[i];
		    END;
		IF inputfile THEN
		    BEGIN
		    IF device = 'TTY   ' THEN
			BEGIN
			write(tty,'TO CONTINUE, HIT THE RETURN KEY *');
			break(tty);
			END;
		    reset(currentfile,filename,protection,ufd,device);
		    IF extdefaulted AND eof(currentfile) THEN
			reset(currentfile,tempfile,protection,ufd,device);
		    END
		ELSE
		    rewrite(currentfile,filename,protection,ufd,device);
		END;
    EXIT IF ( (NOT eof(currentfile) AND inputfile) OR (eof(currentfile) AND NOT inputfile) ) AND NOT error;
	IF source <> teletype THEN
	    BEGIN
	    source := teletypeoutput; initialize
	    END;
	IF error THEN writeln(tty,'%? SYNTAX ERROR: REENTER')
	ELSE
	    BEGIN
	    write(tty,'%? NO ACCESS TO ');
	    IF filename = '         ' THEN write(tty,fileident:6,'.',fileident[7],fileident[8],fileident[9])
	    ELSE
		BEGIN
		write(tty,filename:6,'.',filename[7],filename[8],filename[9]);
		IF extdefaulted THEN
		    write(tty,' NOR TO ',tempfile:6,'.   ');
		END;
	    writeln(tty,' OR NOT FOUND: REENTER')
	    END;
	break(tty);

	IF source IN [teletype,teletypeinput] THEN
	    BEGIN
	    write(tty,fileident,'= ');break(tty);
	    IF source = teletypeinput THEN initialize
	    ELSE readln(tty)
	    END;

	usercall := false;
	getfilename(tty,filename,protection,ufd,device,'          ');
	IF device = 'LPT   ' THEN enter('LPT       ',0) ;

	error := (inputfile AND NOT defaulted AND (device = 'LPT   ')) OR error;
	END
    END (*STARTFILE*);

PROCEDURE getparameter(VAR currentfile: anyfile;
		       VAR fileident,programname:alfa;
		       inputfile:boolean);
    VAR
	protection, ufd: integer;

    BEGIN (*GETPARAMETER*)
    getstatus(currentfile,file_old,prot_old,ufd_old,device_old);
    askfilename(filename,protection,ufd,device,fileident,programname,inputfile, fromtmpfile,breakchar);
    usercall:=false;
    startfile(currentfile,filename,protection,ufd,device,inputfile,fileident,'   ');
    END (*GETPARAMETER*) ;
	(** OPTION FIND_SWITCH GETOPTION PICTURE **)

    (**********************************************************************
     *
     *    FUNCTION OPTION
     *
     *     - TEST IF <SWITCH> "SWITCHNAME" HAS BEEN
     *       SPECIFIED IN THE DECSYSTEM-10 COMMAND-STRING
     *       INTERPRETED BY PREVIOUS GETPARAMETER-/GETFILENAME-CALLS.
     *
     *       OPTION IS A PRE-DECLARED FUNCTION AND AVAILABLE TO EVERY
     *       PASCAL USER.
     *
     **********************************************************************)

FUNCTION option(switchname: alfa): boolean;

    FUNCTION find_switch( ftree: swp): boolean;
	BEGIN
	IF ftree <> NIL THEN
	    WITH ftree↑ DO
		IF switchname = name THEN
		    BEGIN
		    find_switch := true; current_switch := ftree
		    END
		ELSE
		    IF switchname < name THEN
			find_switch := find_switch(left)
		    ELSE
			find_switch := find_switch(right)
	ELSE find_switch := false
	END (* FIND_SWITCH *);

    BEGIN (*OPTION*)
    IF switch_tree = NIL THEN
	option := false
    ELSE
	option := find_switch(switch_tree)
    END (*OPTION*);

    (**********************************************************************
     *
     *   PROCEDURE GETOPTION
     *
     *    - ASSIGN <VALUE> OF "SWITCHNAME" TO "SWITCHVALUE".
     *
     *      GETOPTION IS A PRE-DECLARED PROCEDURE AND AVAILABLE TO EVERY
     *      PASCAL USER.
     *
     **********************************************************************)

PROCEDURE getoption(switchname: alfa; VAR switchvalue: integer);
    BEGIN
    IF option(switchname) THEN
	WITH current_switch↑ DO
	    switchvalue := value
    ELSE
	switchvalue := 0
	;
    END (* GETOPTION *);

    (**********************************************************************
     *
     *   PROCEDURE GETNEXTCALL
     *
     *    - ASSIGN <VALUE> OF "NEXT_NAME" TO "FILENAME" AND
     *          <VALUE> OF "NEXT_DEVICE" TO "DEVICE", THAT IS,
     *          TRANSMIT THE DATA OF THE NEXT PROGRAM TO BE CALLED.
     *
     *      GETNEXTCALL IS A PRE-DECLARED PROCEDURE AND AVAILABLE TO EVERY
     *      PASCAL USER.
     *
     **********************************************************************)

PROCEDURE getnextcall (VAR filename: pack9;
		       VAR device: pack6);
    BEGIN (*GETNEXTCALL*)
    filename := next_name;
    device := next_device;
    END (*GETNEXTCALL*);

BEGIN
END.

PROGRAM ddt, debug;

    (************************************************************
     *                                                         *
     *                                                         *
     *                 PASCAL-DDT PROGRAM                      *
     *                 ******************                      *
     *                                                         *
     *                                                         *
     *       AUTHOR: PETER PUTFARKEN                           *
     *                                                         *
     *       POST - MORTEM - DUMP  BY                          *
     *       B. NEBEL AND B. PRETSCHNER (APR 76)               *
     *                                                         *
     *       INSTITUT FUER INFORMATIK                          *
     *       SCHLUETERSTRASSE 70                               *
     *       D-2000 HAMBURG 13                                 *
     *       GERMANY                                           *
     *                                                         *
     *                                                         *
     ***********************************************************)

CONST
    version   =  'DEBUG(VERSION FROM 25-AUG-76)';
    stopmax  =  20;
    buffmax  = 120;
    bitmax   =  36;
    basemax  =  71;
    strglgth = 120;
    offset   =  40B;
    maxtabs  =   4;
TYPE
    acrange = 0..15; bit = 0..1;
    bitrange = 0..bitmax;
    addrrange = 0..777777B;
    lineelem = PACKED RECORD
			  CASE integer OF
			       1: (code:0..677B; ac:acrange; ib:bit; inxr:acrange; adp:↑lineelem);
			       2: (constant1: integer;
				   db2: addrrange; absline: addrrange)
		      END;
    pageelem = PACKED RECORD
			  instr: 0..677B; ac: acrange; dummybit: bit; inxreg: acrange; pagptr: ↑pageelem;
			  lastline: addrrange; laststop: ↑lineelem
		      END;
    stringtyp = PACKED ARRAY [1:strglgth] OF char;
    cstclass = (int,reel,pset,strd,strg);
    sixbit=PACKED ARRAY[1..6] OF 0..77B;
    csp = ↑constnt;
    constnt = RECORD
		  selfcsp: csp; nocode: boolean;
		  CASE cclass: cstclass OF
		       int : (intval: integer; intval1: integer)
	      END;
    valu = RECORD
	       CASE integer OF
		    1: (ival: integer);
		    2: (rval: real);
		    3: (bval: boolean);
		    4: (valp: csp)
	   END;
    bits5 = 0..37B; bits6 = 0..77B; bits7 = 0..177B;
    bits17 = 0..377777B; bits18 = 0..777777B;
    structform = (scalar,subrange,pointer,power,arrays,records,files,tagfwithid,tagfwithoutid,variant);
    formset=SET OF structform;
    declkind = (standard,declared);
    stp = ↑structure; ctp = ↑identifier;
    structure = PACKED RECORD
			   selfstp: stp; size: addrrange;
			   nocode: boolean;
			   bitsize: bitrange;
			   CASE form: structform OF
				scalar:     (CASE scalkind: declkind OF
						  declared: (db0:bits6; fconst: ctp));
				subrange:   (db1:bits7; rangetype: stp; minv,maxv: valu);
				pointer:    (db2:bits7; eltype: stp);
				power:      (db3:bits7; elset: stp);
				arrays:     (arraypf: boolean; db4:bits6; arraybpaddr: addrrange;
					     aeltype,inxtype: stp);
				records:    (recordpf:boolean; db5:bits6;
					     fstfld: ctp; recvar: stp);
				files:      (db6: bits6; filepf: boolean; filtype: stp);
				tagfwithid,
				tagfwithoutid: (db7:bits7; fstvar: stp;
						CASE boolean OF
						     true : (tagfieldp: ctp);
						     false: (tagfieldtype: stp));
				variant:    (db9: bits7; nxtvar,subvar: stp; firstfield: ctp; varval: valu)
		       END;
    (* ALFA = PACKED ARRAY[1..ALFALENG] OF CHAR; *)
    levrange = 0..10;
    idclass = (types,konst,vars,field,proc,func,labels);
    idkind = (actual,formal);
    packkind = (notpack,packk,hwordr,hwordl);
    bpointer = PACKED RECORD
			  sbits,pbits: bitrange;
			  ibit,dummybit: bit;
			  ireg: acrange;
			  reladdr: addrrange
		      END;
    identifier = PACKED RECORD
			    name: alfa; llink, rlink: ctp;
			    idtype: stp; next: ctp;
			    selfctp: ctp; nocode: boolean;
			    CASE klass: idclass OF
				 konst: (values: valu);
				 vars:  (vkind: idkind; vlev: levrange;
					 channel: acrange; vdummy1: 0..37B; vdummy2:0..777777B;  vaddr: addrrange);
				 field: (CASE packf: packkind OF
					      notpack,
					      hwordl,
					      hwordr:  (fdummy: 0..7777B; fldaddr: addrrange);
					      packk:   (pdummy: 0..7777B; fldbyte: bpointer));
				 proc,
				 func:  (CASE pfdeckind: declkind OF
					      standard: (key: 1..44);
					      declared: (pflev: levrange; pfaddr: addrrange))
			END;
    symbol= (stopsy, tracesy, endsy, notsy, eolsy, ident, intconst, stringconst,
	     charconst, realconst, lbrack, rbrack, comma, period, arrow, plus, minus, mul,
	     slashsy, becomes, eqsy, lparent, rparent,  othersy, stackdumpsy, heapdumpsy);
    ascii_mnemonics = (nul,soh,stx,etx,eot,enq,ack,bel,
		       bs,ht,lf,vt,ff,cr,so,si,
		       dle,dc1,dc2,dc3,dc4,nak,syn,etb,
		       can,em,sub,esc,fs,gs,rs,us,del);

    acr = ↑ aktivierungsrecord;
    aktivierungsrecord = ARRAY [0..0] OF integer;
    attrkind = (cst,varbl,expr);
    attr = RECORD
	       typtr: stp;
	       CASE kind: attrkind OF
		    cst,
		    expr:  (cval: valu);
		    varbl:(packfg: boolean;
			   gaddr: addrrange;
			   gbitcount: bitrange;
			   maxaddr:addrrange)
	   END;
    leftorright=(left,right);
    debugentry = RECORD
		     lastpageelem: pageelem;
		     globalidtree: ctp;
		     standardidtree: ctp;
		     intptr: stp;
		     realptr: stp;
		     boolptr: stp;
		     charptr: stp
		 END;
    statuskind = (initk, stopk, ddtk, runtmerrk, haltk);
    debugstatus = PACKED RECORD
			     dd: 0:77777B;
			     kind: statuskind;
			     returnaddr: addrrange
			 END;
    dynentry = PACKED RECORD
			  dumm1: bits18;         (* LH 140B *)
			  registrs: acr;         (* RH 140B *)
			  stoppy: integer;       (*    141B *)
			  dumm2: bits18;         (* LH 142B *)
			  entryptr: ↑debugentry; (* RH 142B *)
			  dumm3: bits17;
			  interactive: boolean;  (* LH 143B *)
			  stackbottom: acr;      (* RH 143B *)
			  status: debugstatus;   (*    144B *)
			  time_limit: integer;   (*    145B  USED ONLY BY BATCH JOBS *)
			  pushj_indeb: integer;  (*     146B *)
			  dummi146: addrrange;   (*     147B LH *)
			  name_pnt_pnt: acr      (*     147B  RH POINTER OF POINTER OF PROGRAM-NAME *)
		      END;

VAR
    dump, tabs: boolean;
    tabulator: ARRAY[boolean,1..maxtabs] OF integer;
    file_name: PACKED ARRAY[1..9] OF char;
    ascii_change: RECORD
		      CASE integer OF
			   1: (ival: integer);
			   2: (mnemo: ascii_mnemonics)
		  END;
    day, day_time: alfa;
    device:PACKED ARRAY[1..6] OF char;
    ch: char;
    id: alfa;
    val: valu;
    string: ↑stringtyp;
    stringptr, stringindex: stp;
    lgth: integer;
    chcnt, leftspace: integer;
    sy: symbol;
    buffer: PACKED ARRAY[1:buffmax] OF char;
    bufflng: 0:buffmax;
    gpage: integer;     (*CURRENT PAGENUMBER*)
    stoptable: ARRAY[1..stopmax] OF PACKED RECORD
					       thisline: integer;
					       page: addrrange;
					       thisaddr: ↑lineelem;
					       originalcont: integer
					   END;
    stopnr: 0..stopmax;
    entry1: debugentry;
    entry2: dynentry;
    pointercv: PACKED RECORD
			  CASE integer OF
			       0:(addr: addrrange);
			       1:(entptr2: ↑dynentry);
			       2:(stringptr: ↑stringtyp);
			       3:(ctptr: ctp);
			       4:(alfapnt:↑alfa)
		      END;
    heapcv:PACKED RECORD
		      CASE boolean OF
			   true: (cival:integer);
			   false: (cidtype:stp;
				   cacr:acr)
		  END;
    merkbasis,basis, accus, nullptr: acr;
    bytecv: PACKED RECORD
		       CASE boolean OF
			    false: (bits: PACKED ARRAY[1..bitmax] OF bit );
			    true : (intconst: integer)
		   END;
    laddr: addrrange;
    digits, lettersdigitsorleftarrow: SET OF char;
    nl: boolean;
    gattr: attr;

    (******************************************************************************************************)

INITPROCEDURE;
    BEGIN
    digits :=['0'..'9'];
    lettersdigitsorleftarrow:=['A'..'Z','0'..'9', '_'];
    string := NIL;
    tabulator[true,1]:=35;
    tabulator[true,2]:=65;
    tabulator[true,3]:=95;
    tabulator[true,4]:=377777777777B;
    tabulator[false,1]:=0;
    tabulator[false,2]:=0;
    tabulator[false,3]:=35;
    tabulator[false,4]:=377777777777B;
    tabs:=false;
    dump:=false;
    END;


	(** DEBUG [ SYSTEM_ERROR ERROR NEWLINE LENGTH **)

PROCEDURE debug;


    PROCEDURE system_error( kind : integer );
	BEGIN
	writeln(tty);
	writeln(tty,'%? DEBUG-SYSTEM ERROR: ',kind:2);
	halt; (* JUMP TO "HALT.".
	       THERE WILL BE DECDECTED THAT
	       DEBUG IS LOADED. THEREFORE, JUMP TO
	       "ERRDB." AND EXIT *)
	END;


    PROCEDURE error;
	BEGIN
	write(tty, '$', '↑ ':chcnt+1 );
	gattr.typtr := NIL
	END (*ERROR*);


    PROCEDURE newline;
	VAR
	    i:integer;
	BEGIN
	i:=1;
	IF tabs THEN
	    WHILE (tabulator[dump,i] <= chcnt) DO
		i:=i+1;
	IF (i = maxtabs) OR NOT tabs THEN
	    BEGIN
	    writeln(tty);
	    write(tty,'$ ',' ':leftspace);
	    chcnt:=leftspace;
	    END
	ELSE
	    BEGIN
	    write(tty,' ':tabulator[dump,i]-chcnt);
	    chcnt:=tabulator[dump,i];
	    END (* ELSE *)
	END (* NEWLINE *);

    FUNCTION length(fval: integer): integer;
	VAR
	    e, h: integer;
	BEGIN
	IF fval < 0 THEN
	    BEGIN
	    e := 1; fval := -fval
	    END
	ELSE e := 0;
	h := 1;
	IF fval >= 10000000000 (* 10**10 *) THEN e := e + 11
	ELSE
	    REPEAT
		e := e + 1; h := h * 10
	    UNTIL (fval < h) ;
	length := e
	END (*LENGTH*);
	(** INSYMBOL NEXTCH **)

    PROCEDURE insymbol;
	CONST
	    max10  = 3817748707;
	    maxexp = 35;
	VAR
	    ival,scale,exp,i: integer;
	    rval,r,fac: real;
	    stringtoolong, sign: boolean;

	PROCEDURE nextch;
	    BEGIN
	    IF eoln(tty) THEN ch:=' '
	    ELSE read(tty,ch);
	    chcnt := chcnt + 1
	    END (*NEXTCH*);
	BEGIN
	WHILE NOT eoln(tty) AND (ch=' ') DO nextch;
	CASE ch OF
	    ' ':
	      sy := eolsy;
	    'A','B','C','D','E','F','G','H','I','J','K','L','M',
	    'N','O','P','Q','R','S','T','U','V','W','X','Y',
	    'Z':
	      BEGIN
	      id := '          '; i := 0;
	      REPEAT
		  IF i < alfalength THEN
		      BEGIN
		      i := i + 1;
		      id[i] := ch
		      END;
		  nextch
	      UNTIL NOT ( ch IN lettersdigitsorleftarrow );
	      sy := ident;
	      IF id='NOT       ' THEN sy:=notsy;
	      IF id='STOP      ' THEN sy:=stopsy;
	      IF id='TRACE     ' THEN sy:=tracesy;
	      IF id='END       ' THEN sy:=endsy;
	      IF id='STACKDUMP ' THEN sy:=stackdumpsy;
	      IF id='HEAPDUMP  ' THEN sy:=heapdumpsy;
	      IF sy IN [stopsy,tracesy,stackdumpsy,heapdumpsy] THEN
		  (* LOOK AHEAD, WHETHER ARGUMENT OR EOL FOLLOWS *)
		  BEGIN
		  WHILE NOT eoln(tty) AND (ch=' ') DO  nextch;
		  IF NOT (ch IN ['0'..'9','A'..'Z',' '] ) THEN sy:= ident
		  END
	      END;
	    '0','1','2','3','4','5','6','7','8',
	    '9':
	      BEGIN
	      ival := 0; sy := intconst;
	      REPEAT
		  IF ival <= max10 THEN ival := 10*ival + ord(ch)-ord('0')
		  ELSE
		      BEGIN
		      error; writeln(tty,'NUMBER TOO LARGE');
		      ival := 0
		      END;
		  nextch
	      UNTIL NOT (ch IN digits);
	      scale := 0;
	      IF ch = '.' THEN
		  BEGIN
		  nextch;
		  IF ch = '.' THEN ch := ':'
		  ELSE
		      BEGIN
		      rval := ival; sy := realconst;
		      IF  NOT (ch IN digits) THEN
			  BEGIN
			  error; writeln(tty,'DIGIT MUST FOLLOW')
			  END
		      ELSE
			  REPEAT
			      rval := 10.0*rval + (ord(ch) - ord('0'));
			      scale := scale - 1; nextch
			  UNTIL  NOT (ch IN digits)
		      END
		  END;
	      IF ch = 'E' THEN
		  BEGIN
		  IF scale = 0 THEN
		      BEGIN
		      rval := ival; sy := realconst
		      END;
		  nextch;
		  sign :=  ch = '-' ;
		  IF (ch = '+') OR sign THEN nextch;
		  exp := 0;
		  IF  NOT (ch IN digits) THEN
		      BEGIN
		      error; writeln(tty,'DIGIT MUST FOLLOW')
		      END
		  ELSE
		      REPEAT
			  exp := 10*exp + ord(ch) - ord('0');
			  nextch
		      UNTIL  NOT (ch IN digits);
		  IF sign THEN scale := scale - exp
		  ELSE scale := scale + exp;
		  IF abs(scale + length(ival) - 1) > maxexp THEN
		      BEGIN
		      error; writeln(tty,'EXPONENT TOO LARGE');
		      scale := 0
		      END
		  END;
	      IF scale <> 0 THEN
		  BEGIN
		  r := 1.0;   (*NOTE POSSIBLE OVERFLOW OR UNDERFLOW*)
		  IF scale < 0 THEN
		      BEGIN
		      fac := 0.1; scale := -scale
		      END
		  ELSE fac := 10.0;
		  REPEAT
		      IF odd(scale) THEN r := r*fac;
		      fac := sqr(fac); scale := scale DIV 2
		  UNTIL scale = 0;
		  (*NOW R = 10↑SCALE*)
		  rval := rval*r
		  END;
	      IF sy = intconst THEN val.ival := ival
	      ELSE val.rval := rval
	      END;
	    ':':
	      BEGIN
	      nextch;
	      IF  ch = '=' THEN
		  BEGIN
		  sy := becomes; nextch
		  END
	      ELSE sy := othersy
	      END;
	    '''':
	       BEGIN
	       lgth := 0; stringtoolong := false;
	       IF string = NIL THEN
		   BEGIN
		   new(string); new(stringptr,arrays); new(stringindex,subrange);
		   WITH  stringindex↑ DO
		       BEGIN
		       size := 1; bitsize := 7;
		       rangetype := entry1.intptr; minv.ival := 1
		       END;
		   WITH stringptr↑ DO
		       BEGIN
		       bitsize := bitmax; aeltype := entry1.charptr;
		       inxtype := stringindex; arraypf := true
		       END
		   END;
	       REPEAT
		   REPEAT
		       nextch;
		       IF lgth < strglgth THEN
			   BEGIN
			   lgth := lgth + 1; string↑[lgth] := ch
			   END
		       ELSE stringtoolong := true
		   UNTIL eoln(tty) OR (ch = '''');
		   IF stringtoolong THEN
		       BEGIN
		       error; writeln(tty,'STRING CONSTANT IS TOO LONG')
		       END;
		   IF ch <> '''' THEN
		       BEGIN
		       error; writeln(tty,'STRING CONSTANT CONTAINS "<CR><LF>"')
		       END
		   ELSE nextch
	       UNTIL ch <> '''';
	       lgth := lgth - 1;   (*NOW LGTH = NR OF CHARS IN STRING*)
	       IF lgth = 1 THEN
		   BEGIN
		   sy := charconst; val.ival := ord(string↑[1])
		   END
	       ELSE
		   BEGIN
		   sy := stringconst;
		   stringindex↑.maxv.ival := lgth;
		   stringptr↑.size := (lgth + 4) DIV 5
		   END
	       END;
	    '=':
	      BEGIN
	      sy := eqsy;  nextch
	      END;
	    '/':
	      BEGIN
	      sy := slashsy; nextch
	      END;
	    '[':
	      BEGIN
	      sy := lbrack; nextch
	      END;
	    ']':
	      BEGIN
	      sy := rbrack; nextch
	      END;
	    '.':
	      BEGIN
	      sy := period; nextch
	      END;
	    '↑':
	      BEGIN
	      sy := arrow;  nextch
	      END;
	    ',':
	      BEGIN
	      sy := comma;  nextch
	      END;
	    '+':
	      BEGIN
	      sy := plus;   nextch
	      END;
	    '*':
	      BEGIN
	      sy := mul;    nextch
	      END;
	    '-':
	      BEGIN
	      sy := minus;  nextch
	      END;
	    '(':
	      BEGIN
	      sy := lparent;  nextch
	      END;
	    ')':
	      BEGIN
	      sy := rparent;  nextch
	      END;
	    OTHERS:
		 sy := othersy
	    END;
	END (*INSYMBOL*);

	(** ACRPOINT TESTGLOBALBASIS IDTREE FIRSTBASIS SUCCBASIS SEARCHSECTION SEARCHID **)
    FUNCTION acrpoint(fint:integer;lleft:leftorright): acr;
	(*CONVERTS INTEGER TO ACR-POINTER*)
	VAR
	    acr_int: PACKED RECORD
				CASE boolean OF
				     false:(lint: integer);
				     true: (lacr,lacl: acr)
			    END;
	BEGIN
	WITH acr_int DO
	    BEGIN
	    lint := fint;
	    IF lleft=left THEN acrpoint := lacl
	    ELSE acrpoint := lacr
	    END
	END (*ACRPOINT*);

    PROCEDURE testglobalbasis;
	BEGIN
	IF basis = entry2.stackbottom THEN basis := nullptr
	END (*TESTGLOBALBASIS*);

    FUNCTION idtree: ctp;
	(*POINTS TO THE IDTREE OF THE PROCEDURE, TO WHICH BASIS POINTS*)
	VAR
	    i: integer;
	    lacr: acr;
	BEGIN
	IF basis = nullptr THEN idtree := entry1.globalidtree
	ELSE
	    BEGIN
	    lacr := acrpoint ( basis↑[0] - 1, right );
	    i := lacr↑[0];
	    REPEAT
		i := i - 1;
		lacr := acrpoint ( i, right)
	    UNTIL  ord(acrpoint(lacr↑[0],right))  <>  777777B (*HRR BASIS,-1(BASIS)*);
	    WITH pointercv DO
		BEGIN
		addr := lacr↑[0];
		idtree := ctptr
		END
	    END
	END (*IDTREE*);

    PROCEDURE firstbasis;
	(*GENERATES BASISPOINTER TO 'AKTIVIERUNGSRECORD' OF UNDERBREAKED PROCEDURE*)
	BEGIN
	basis := acrpoint ( accus↑[0 +16B], right );
	testglobalbasis
	END (*FIRSTBASIS*);

    PROCEDURE succbasis(side: leftorright);
	(*GENERATES BASISPOINTER TO 'AKTIVIERUNGSR.'
	 OF STATIC/DYNAMIC HIGHER PROCEDURE)*)
	(*SIDE:  RIGHT FOR STATIC LINK
	 LEFT FOR DYNAMIC LINK*)

	VAR
	    oldbasis:acr;
	BEGIN
	oldbasis:=basis;
	basis := acrpoint( basis↑[0-1], side );
	testglobalbasis;
	IF ord(oldbasis) <= ord(basis) THEN
	    BEGIN
	    basis:=nullptr;
	    tabs:=false; newline;
	    write(tty,'ERROR IN PROCEDURE-BACKTRACING'); newline;
	    END;
	END (*SUCCBASIS*);

    PROCEDURE searchsection(fcp: ctp; VAR fcp1: ctp);
	LABEL
	    1;
	BEGIN
	WHILE fcp <> NIL DO WITH fcp↑ DO
	    BEGIN
	    IF name = id THEN GOTO 1;
	    IF name < id THEN fcp := rlink
	    ELSE fcp := llink
	    END;
	1:
	fcp1 := fcp
	END (*SEARCHSECTION*);

    PROCEDURE searchid(VAR fcp: ctp);
	LABEL
	    1;
	VAR
	    lcp: ctp;
	BEGIN
	firstbasis;
	LOOP
	    searchsection( idtree, lcp );
	    IF lcp <> NIL THEN GOTO 1
	EXIT IF basis = nullptr;
	    succbasis ( right(*=STATIC*) )
	    END;
	searchsection( entry1.standardidtree, lcp );
	1:
	fcp := lcp
	END (*SEARCHID*);
	(** GETBOUNDS COMPTYPES **)

    PROCEDURE getbounds(fsp: stp; VAR fmin,fmax: integer);
	(*GET INTERNAL BOUNDS OF SUBRANGE OR SCALAR TYPE*)
	(*ASSUME (FSP <> NIL) AND (FSP↑.FORM <= SUBRANGE) AND (FSP <> INTPTR)
	 AND  NOT COMPTYPES(REALPTR,FSP)*)
	BEGIN
	WITH fsp↑ DO
	    IF form = subrange THEN
		BEGIN
		fmin := minv.ival; fmax := maxv.ival
		END
	    ELSE
		BEGIN
		fmin := 0;
		IF fsp = entry1.charptr THEN fmax := 177B
		ELSE
		    IF fconst <> NIL THEN fmax := fconst↑.values.ival
		    ELSE fmax := 0
		END
	END (*GETBOUNDS*) ;

    FUNCTION comptypes(fsp1,fsp2: stp) : boolean;
	(*DECIDE WHETHER STRUCTURES POINTED AT BY FSP1 AND FSP2 ARE COMPATIBLE*)
	VAR
	    nxt1,nxt2: ctp; comp: boolean; lmin,lmax,i: integer;
	BEGIN
	IF fsp1 = fsp2 THEN comptypes := true
	ELSE
	    IF (fsp1 <> NIL) AND (fsp2 <> NIL) THEN
		IF fsp1↑.form = fsp2↑.form THEN
		    CASE fsp1↑.form OF
			scalar:
			     comptypes := false;
			     (* IDENTICAL SCALARS DECLARED ON DIFFERENT LEVELS ARE
			      NOT RECOGNIZED TO BE COMPATIBLE*)
			subrange:
			       comptypes := comptypes(fsp1↑.rangetype,fsp2↑.rangetype);
			pointer:
			      comptypes := comptypes(fsp1↑.eltype,fsp2↑.eltype);
			power:
			    comptypes := comptypes(fsp1↑.elset,fsp2↑.elset);
			arrays:
			     BEGIN
			     getbounds (fsp1↑.inxtype,lmin,lmax);
			     i := lmax-lmin;
			     getbounds (fsp2↑.inxtype,lmin,lmax);
			     comptypes := comptypes(fsp1↑.aeltype,fsp2↑.aeltype)
			     AND (fsp1↑.arraypf = fsp2↑.arraypf) AND ( i = lmax - lmin )
			     END;
			     (*ALTERNATIVES: -- ADD A THIRD BOOLEAN TERM: INDEXTYPE MUST
			      BE COMPATIBLE. MAY GIVE TROUBLE FOR ENT OF STRINGCONSTANTS
			      -- ADD A FOURTH BOOLEAN TERM: LOWBOUNDS MUST
			      BE THE SAME*)
			records:
			      BEGIN
			      nxt1 := fsp1↑.fstfld; nxt2 := fsp2↑.fstfld; comp := true;
			      WHILE (nxt1 <> NIL) AND (nxt2 <> NIL) DO
				  BEGIN
				  comp := comptypes(nxt1↑.idtype,nxt2↑.idtype) AND comp;
				  nxt1 := nxt1↑.next; nxt2 := nxt2↑.next
				  END;
			      comptypes := comp AND (nxt1 = NIL) AND (nxt2 = NIL)
			      AND (fsp1↑.recvar = NIL) AND (fsp2↑.recvar = NIL)
			      END;
			      (*IDENTICAL RECORDS ARE RECOGNIZED TO BE COMPATIBLE
			       IF NO VARIANTS OCCUR*)
			files:
			    comptypes := comptypes(fsp1↑.filtype,fsp2↑.filtype)
			END (*CASE*)
		ELSE (*FSP1↑.FORM <> FSP2↑.FORM*)
		    IF fsp1↑.form = subrange THEN comptypes := comptypes(fsp1↑.rangetype,fsp2)
		    ELSE
			IF fsp2↑.form = subrange THEN comptypes := comptypes(fsp1,fsp2↑.rangetype)
			ELSE comptypes := false
	    ELSE comptypes := true
	END (*COMPTYPES*) ;
	(** NEXTBYTE PUTNEXTBYTE **)

    FUNCTION nextbyte(fbitsize: integer ): integer;
	VAR
	    lval,j: integer;
	BEGIN
	WITH gattr DO
	    IF packfg THEN
		BEGIN
		lval := 0;
		IF fbitsize + gbitcount  >  bitmax THEN
		    BEGIN
		    gaddr := gaddr + 1;
		    gbitcount := 0
		    END;
		IF fbitsize = bitmax THEN lval := basis↑[gaddr]
		ELSE
		    WITH bytecv DO
			BEGIN
			intconst := basis↑[gaddr];
			FOR j := gbitcount + 1  TO gbitcount + fbitsize DO
			    lval := lval*2 + bits[j]
			END;
		gbitcount := gbitcount + fbitsize;
		nextbyte := lval
		END (*IF PACKFG*)
	    ELSE
		BEGIN
		IF gbitcount > 0 THEN system_error(1);
		nextbyte := basis↑[gaddr];
		gaddr := gaddr + 1; gbitcount := 0
		END
	END (*NEXTBYTE*);

    PROCEDURE putnextbyte( fbitsize, fval: integer );
	VAR
	    j: integer;
	BEGIN
	WITH gattr, bytecv DO
	    BEGIN
	    IF fbitsize + gbitcount > bitmax THEN
		BEGIN
		gaddr := gaddr + 1;   gbitcount := 0
		END;
	    intconst := basis↑[gaddr];
	    FOR j := gbitcount + fbitsize  DOWNTO  gbitcount+ 1  DO
		BEGIN
		bits[j] := ord(odd(fval));
		fval := fval DIV 2
		END;
	    gbitcount := gbitcount + fbitsize;
	    basis↑[gaddr] := intconst
	    END
	END (*PUTNEXTBYTE*);
	(** LOAD GETFIELD SELECTOR **)

    PROCEDURE load;
	(* LOAD VALUE, DESCRIBED BY GATTR,  INTO GATTR.CVAL*)
	BEGIN
	WITH gattr DO
	    IF kind = varbl THEN
		IF typtr <> NIL THEN
		    IF typtr↑.form <= pointer THEN
			BEGIN
			kind := expr; cval.ival := nextbyte(gbitcount)
			END;
	END (*LOAD*);

    PROCEDURE getfield( fcp:ctp );
	BEGIN
	WITH fcp↑, gattr DO
	    BEGIN
	    IF klass <> field THEN system_error(3);
	    CASE packf OF
		notpack,
		hwordl:
		     BEGIN
		     gaddr := gaddr + fldaddr; gbitcount := 0
		     END;
		hwordr:
		     BEGIN
		     gaddr := gaddr + fldaddr;
		     gbitcount := 18
		     END;
		packk:
		    WITH fldbyte DO
			BEGIN
			gaddr := gaddr + reladdr;
			gbitcount := bitmax - sbits -pbits
			END
		END (*CASE*);
	    packfg := packf <> notpack;
	    typtr := idtype
	    END (*WITH*)
	END (*GETFIELD*);

    PROCEDURE expression; FORWARD;

    PROCEDURE selector;
	LABEL
	    1;
	VAR
	    lcp: ctp;
	    lmin, lmax: integer;
	    lattr: attr;
	    index, i, indexoffset, bytesinword: integer;
	BEGIN
	WHILE sy IN [lbrack,arrow,period] DO  WITH gattr DO
	    CASE sy OF
		lbrack:
		     BEGIN
		     REPEAT
			 IF typtr <> NIL THEN
			     IF typtr↑.form <> arrays THEN
				 BEGIN
				 error; writeln(tty,'TYPE OF VARIABLE IS NOT ARRAY')
				 END;
			 insymbol;
			 lattr := gattr;
			 expression;
			 IF (typtr <> NIL) AND (lattr.typtr<>NIL) THEN
			     BEGIN
			     IF comptypes( gattr.typtr, lattr.typtr↑.inxtype ) THEN WITH gattr DO
				 BEGIN
				 load;
				 index := cval.ival;
				 gattr := lattr;
				 WITH typtr↑ DO
				     BEGIN
				     getbounds(inxtype, lmin, lmax );
				     indexoffset := index - lmin;
				     IF indexoffset < 0 THEN i := - indexoffset
				     ELSE
					 IF index > lmax THEN
					     i:= index - lmax
					 ELSE
					     GOTO 1;
				     error; write(tty,'ARRAY-INDEX BY ', i:length(i));
				     IF indexoffset < 0 THEN writeln(tty, ' LESS THAN LOW BOUND')
				     ELSE writeln(tty, ' GREATER THAN HIGH BOUND');
	1:
				     IF  arraypf THEN
					 BEGIN
					 packfg := true;
					 bytesinword := bitmax DIV aeltype↑.bitsize; i := indexoffset MOD bytesinword;
					 gaddr := gaddr + (indexoffset DIV bytesinword);
					 IF indexoffset < 0 THEN
					     BEGIN
					     gaddr := gaddr-1;
					     i := i + bytesinword
					     END;
					 gbitcount := i * aeltype↑.bitsize
					 END
				     ELSE gaddr := gaddr + (aeltype↑.size * indexoffset);
				     IF typtr <> NIL THEN typtr := aeltype
				     END (*WITH TYPTR↑*)
				 END (*IF COMPTYPES*)
			     ELSE
				 BEGIN
				 error; writeln(tty,'INDEX-TYPE IS NOT COMPATIBLE WITH DECLARATION')
				 END
			     END (*IF TYPTR<>NIL*)
		     UNTIL sy <> comma;
		     IF sy = rbrack THEN insymbol
		     ELSE
			 BEGIN
			 error; writeln(tty,'"]" EXPECTED')
			 END;
		     END;
		period:
		     BEGIN
		     IF typtr <> NIL THEN
			 IF typtr↑.form <> records THEN
			     BEGIN
			     error; writeln(tty,'TYPE OF VARIABLE IS NOT RECORD')
			     END;
		     insymbol;
		     IF sy = ident THEN
			 BEGIN
			 IF typtr <> NIL THEN
			     BEGIN
			     searchsection(typtr↑.fstfld, lcp);
			     IF lcp = NIL THEN
				 BEGIN
				 error; writeln(tty,'NO SUCH FIELD IN THIS RECORD')
				 END
			     ELSE getfield(lcp)
			     END (*TYPTR <> NIL*);
			 insymbol
			 END
		     ELSE
			 BEGIN
			 error; writeln(tty,'IDENTIFIER EXPECTED')
			 END
		     END (*PERIOD*);
		arrow:
		    BEGIN
		    insymbol;
		    IF typtr <> NIL THEN
			CASE typtr↑.form OF
			    pointer:
				  BEGIN
				  gaddr := nextbyte(18);
				  IF gaddr = ord(NIL) THEN
				      BEGIN

				      error; writeln(tty,'POINTER IS NIL')

				      END
				  ELSE
				      IF (gaddr >= ord(accus)) OR
					  (gaddr <= ord(acrpoint(accus↑[0+15B],right))) THEN
					  BEGIN
					  error; writeln(tty,'POINTER IS OUT OF HEAP')
					  END
				      ELSE
					  WITH heapcv DO
					      BEGIN
					      typtr := typtr↑.eltype;
					      merkbasis:=acrpoint(gaddr-1,right);
					      cival:=merkbasis↑[0];
					      IF (gaddr < ord(cacr) )
						  AND  (ord(cidtype) >= ord(NIL) ) THEN
						  maxaddr:=ord(cacr)-1
					      ELSE maxaddr:=ord(NIL);
					      END (* WITH HEAPCV *);
				  END;
			    files:
				BEGIN
				gaddr := basis↑[gaddr];
				typtr := typtr↑.filtype
				END;
			    OTHERS:
				 BEGIN
				 error;
				 writeln(tty,'TYPE OF VARIABLE MUST BE FILE OR POINTER')
				 END
			    END (*CASE FORM*);
		    packfg := false; gbitcount := 0
		    END (*ARROW*)
		END (*CASE*)
	END (*SELECTOR*);
	(** VARIABLE **)

    PROCEDURE variable;
	VAR
	    lcp: ctp;

	BEGIN
	(*VARIABLE*)
	searchid(lcp);
	insymbol;
	IF lcp = NIL THEN
	    BEGIN
	    error; writeln(tty,'NOT FOUND')
	    END
	ELSE
	    BEGIN
	    WITH lcp↑, gattr  DO
		CASE klass OF
		    types:
			BEGIN
			error; writeln(tty,'!TYPE')
			END;
		    konst:
			BEGIN
			kind := cst; cval := values;
			typtr := idtype
			END;
		    vars:
		       BEGIN
		       kind := varbl;
		       gaddr := vaddr + ord(basis); basis := nullptr;
		       gbitcount := 0;
		       IF vkind = formal THEN   gaddr := basis↑[gaddr];
		       typtr := idtype; packfg := false;
		       selector
		       END;
		       (*FIELD: WRITE(TTY,'NOT IMPL.; TYPE <RECORD>.<FIELD> ...');*)
		    proc:
		       BEGIN
		       error; writeln(tty,'!PROCEDURE')
		       END;
		    func:
		       BEGIN
		       error; writeln(tty,'!FUNCTION')
		       END
		    END (*CASE CLASS*)
	    END
	END (*VARIABLE*);
	(** EXPRESSION SIMPLEEXPRESSION TERM FACTOR **)

    PROCEDURE expression;

	PROCEDURE simpleexpression;
	    VAR
		signed: boolean;
		lattr:  attr;
		lop: symbol;

	    PROCEDURE term;
		VAR
		    lattr: attr;

		PROCEDURE factor;
		    BEGIN
		    CASE sy OF
			ident:
			    variable;
			intconst,
			realconst,
			charconst:
				WITH gattr DO
				    BEGIN
				    kind := cst; cval := val;
				    IF sy = intconst THEN typtr := entry1.intptr
				    ELSE
					IF sy = realconst THEN typtr := entry1.realptr
					ELSE typtr := entry1.charptr;
				    insymbol
				    END;
			stringconst:
				  WITH gattr DO
				      BEGIN
				      typtr := stringptr;
				      kind := varbl; packfg := false;
				      gaddr := ord(string); gbitcount := 0;
				      insymbol
				      END;
			notsy:
			    BEGIN
			    insymbol; factor;
			    WITH gattr DO
				IF typtr = entry1.boolptr THEN
				    BEGIN
				    load;  cval.bval  :=  NOT cval.bval
				    END
				ELSE
				    BEGIN
				    error; writeln(tty,'TYPE IS NOT BOOLEAN')
				    END
			    END (* NOT *);
			lparent:
			      BEGIN
			      insymbol; expression;
			      IF sy = rparent THEN insymbol
			      ELSE
				  BEGIN
				  error;
				  writeln(tty,'")" EXPECTED')
				  END
			      END (* ( *) ;
			OTHERS:
			     BEGIN
			     error; writeln(tty,'FACTOR EXPECTED')
			     END
			END (* CASE *)
		    END (*FACTOR*);

		BEGIN (*TERM*)
		factor;
		WHILE sy = mul DO
		    BEGIN
		    insymbol;
		    load; lattr := gattr;
		    factor; load;
		    IF comptypes(lattr.typtr,entry1.intptr) AND
			comptypes(gattr.typtr,entry1.intptr) THEN gattr.cval.ival := gattr.cval.ival * lattr.cval.ival
		    ELSE
			BEGIN
			error; writeln(tty,'OPERANDS MUST BE OF TYPE INTEGER')
			END
		    END
		END (*TERM*);

	    BEGIN (*SIMPLEEXPRESSION*)
	    IF sy IN [plus,minus] THEN WITH gattr DO
		BEGIN
		signed := sy=minus ;
		insymbol; term;
		IF comptypes(typtr,entry1.intptr) OR comptypes(typtr,entry1.realptr) THEN
		    BEGIN
		    IF signed THEN
			BEGIN
			load; cval.ival := - cval.ival
			END
		    END
		ELSE
		    BEGIN
		    error; writeln(tty,'NO SIGN ALLOWED HERE')
		    END
		END (*MINUS*)
	    ELSE term;
	    WHILE sy IN [plus,minus] DO
		BEGIN
		lop := sy; insymbol;
		load; lattr := gattr;
		term; load;
		IF comptypes(lattr.typtr,entry1.intptr) AND
		    comptypes(gattr.typtr,entry1.intptr) THEN
		    IF lop = plus THEN gattr.cval.ival := lattr.cval.ival + gattr.cval.ival
		    ELSE gattr.cval.ival := lattr.cval.ival - gattr.cval.ival
		ELSE
		    BEGIN
		    error; writeln(tty,'OPERANDS MUST BE OF TYPE INTEGER')
		    END
		END
	    END (*SIMPLEEXPRESSION*);

	BEGIN
	simpleexpression
	END (*EXPRESSION*);
_∩PT(A'⊃∪→)λ1=+(A/I∪)'
β→β$↓!+)'%1¬∪(TTR~(~∀@@A!%∨
	+%∀AgQS→iKH1=khQ]¬[JuC1MBRv4∀∪→β	_~∀$@@@@Dv~∀∪Yβ$~∀$@@@AIk\uS9iKOKHv~∀∪	∂∪≤4∀∪
∨HAek\tz@b↓)≡@b@A	≡~(∩@@@↓∪A]¬[K7eU]:zNNA)⊃∃≤A∂∨Q≡@b~(∩@@@↓→'
↓oeSi∀Qiir1]C[Kmek]:$v~∀∩Dt~∀∪
QG]hh{GQG9hWek8Zbv~(∪≥λPU'⊃%
)λa∨+(T$v~∀~(@@@AA%∨π⊃+%
A]eSiKMGCYCHQMmC0uS]i∃OKdv↓Mg`t↓gi`Rl~∀∪-¬$~∀∩@@AY
`tAGQ`vAY∃]NY[¬qmCX1[S]m¬XtAS9iKOKHv~∀∩@@AYYCYjt↓mCYjl~∀∪¬∃∂∪≤~(∪YK]≤tz`v4∀∪∪↓Mg`@p|A≥∪0A)⊃8A/∪) AMgaxA	≡~(∩@@@↓πβ'
↓M←eZ↓∨~∀$∪gGC1Cdt~(∩∩@@@A∪↓gGCY-S]H{MiC]I¬eHA)!≤~∀$∩∩A∪_AMg`uK]iedb]S]QaidAQ⊃≤~(∩∩∩@@@A¬∃∂∪≤~(∩∩∩@@@AY∃]N@ttAYK]≥iPQMYCXRv↓oeSi∀Qiir0AMmC0uYK]≤R~∀∩$∩@@@A≥λ4∀∩∩∩↓→'
4∀∩∩∩@@@A%AMg@{K]iIrb]e∃CYaiHA)⊃8A/∪) AYmC1jA	≡4∀∩∩∩$A¬∂%≤~∀∩$∩∩ASYCX@ttAMmC0v~∀∩$∩∩AoISiJQQirXAImCXRlAYK]≤@tz@Dn~∀∩$∩∩A9λ~∀∩$∩@@@A→'∀@PTzt⎇π⊃βI!)$T$~∀∩∩$∩A¬≥∪≤~∀$∩∩∩A%AMg@@x|A∃]ierD]GQCIaidAQ⊃≤AMsgiK41Kee=dPhR4∀∩∩∩$A→'∀~∀∩∩$∩@@@A∪@!MmCXp`RA∨H@QMm¬X|bn]∧RA)!≤~∀$∩∩∩∩↓¬∂∪8~∀∩∩$∩∩AoISiJQQirYMYCXuY∃]OiP!MmCX$XN@Q%→_\A
⊃β$\$NRwY∃]NtzDfWYK9OiPQ→mCXRl~∀∩∩$∩∩A9λ~∀∩$∩∩@@@A→M
~∀∩$∩∩∩A	∂∪≤4∀∩∩∩$∩A∪QMmC0xha∧$A∨$@!MmCXtbno∧$A)⊃8~∀∩∩$∩∩@@@A¬≥∪≤~∀$∩∩∩∩@@@A¬gGSRaGQC]≥J]Sm¬X@tz↓MmCXl~∀∩∩$∩∩@@@A∪↓MmCXz@bn]∧A)⊃∃≤ACg
SR1G!C]OJ9SmCXtz@hA∧v~∀$∩∩∩∩@@@A]eSiJ!iirY¬gGSRaGQC]≥J][]∃[↑tf$vAYK9N@tzf~∀∩$∩∩∩@@@A9λ~∀∩$∩∩∩A∃→'
~(∩∩∩∩$@@@@↓¬∂∪8~∀∩∩$∩∩@@@Aoe%iJQiQrXNN≤NYGQHQMmC0RXNN≤NRvA1K]N@hz@f~(∩∩∩∩$@@@@↓≥λ~(∩∩∩∩$A≥λl~∀∩∩$∩A≥⊂~∀∩∩@@@A∃→'
@ U'πβ1↔∪≥λtz⎇	
→β%⊂TR~∀$∩∩A¬∃∂∪≤~(∩∩∩A1G`@ttAMG←9ghv~(∩∩∩A%AMm¬X@|z`A)⊃∃≤@A/!∪→
Acp↑.values.ival > fval DO lcp := lcp↑.next;
			 WITH lcp↑ DO
			     IF values.ival <> fval THEN
				 BEGIN
				 writescalar(fval,entry1.intptr); write(tty,'(OUT OF RANGE)'); leng := 14
				 END
			     ELSE
				 shifted_out(name);
			 END;
		subrange:
		       BEGIN
		       writescalar(fval,rangetype); leng := 0;
		       IF NOT comptypes(entry1.realptr,rangetype) THEN
			   BEGIN
			   IF rangetype<>entry1.intptr THEN
			       getbounds(rangetype,minval,maxval);
			   IF (fval <= maxval) AND (fval >= minval) OR (entry1.intptr=rangetype) THEN
			       BEGIN
			       getbounds(fsp,minval,maxval);
			       IF (fval > maxval) OR (fval < minval) THEN
				   BEGIN
				   write(tty,'(OUT OF SUBRANGE)');
				   leng:=17;
				   END (* IF ..>...<.. *);
			       END (* IF ..=<..=>..=.. *);
			   END (* IF COMPTYPES *);
		       END;
		pointer:
		      IF fval = ord(NIL) THEN
			  BEGIN
			  write(tty,'NIL'); leng := 3
			  END
		      ELSE
			  BEGIN
			  write(tty,fval:6:o,'B');
			  IF (fval < accus↑[0+15B]) OR (fval > ord(accus)) THEN
			      BEGIN
			      write(tty,'(OUT OF HEAP)');
			      leng:=20;
			      END
			  ELSE
			      leng:=7;
			  END;
		OTHERS:
		     system_error(5)
		END (*CASE*);
	chcnt := chcnt + leng;
	tabs:=true;
	END (*WRITESCALAR*);

    PROCEDURE putsixbit(fsixbit:sixbit;fix:integer);
	VAR
	    i:integer;
	BEGIN
	FOR i:=1 TO fix DO
	    write(tty,chr(fsixbit[i]+40B));
	chcnt:=chcnt+fix;
	END;
	(** WRITESTRUCTURE WRITEFIELDLIST **)

    PROCEDURE writestructure( fsp: stp );
	TYPE
	    ascii=PACKED ARRAY[1..5] OF char;
	    threebit=PACKED ARRAY[1..12] OF 0..7;
	    halfword=PACKED ARRAY[leftorright] OF bits18;

	    filblktyp=RECORD
			  fileof,filptr:integer;
			  fileol:boolean;
			  filsta,filcls,filout,filin,filent,
			  fillkp,filopn:integer;
			  fildev:sixbit;
			  filpbh:halfword;
			  filext,filnam:sixbit;
			  filppn,filprot:threebit;
			  filbtc,filbtp,filbfh:integer;
			  fillnr:ascii;
			  filcmp,filcnt:integer
		      END;
	VAR
	    stinx, inx, i : integer;
	    llmax, currcompo, lmin, lmax, leng, lspace: integer;
	    oattr, lattr: attr;
	    illstring,nexteq, lasteq, zero, nocomma: boolean;
	    setwandel: RECORD
			   CASE boolean OF
				false: (const1: integer; const2: integer);
				true:  (mask: SET OF 0..basemax)
		       END;
	    filblkwandel:RECORD
			     CASE boolean OF
				  true:(int:integer);
				  false:(ptr:↑filblktyp)
			 END;


	PROCEDURE writefieldlist(fnextfld: ctp; frecvar: stp);
	    LABEL
		1;
	    VAR
		lsp: stp;
		j,lmin,lmax : integer;
		lattr : attr;
		tagf  : ctp;
	    BEGIN
	    lattr := gattr; tagf := NIL;
	    IF frecvar <> NIL THEN
		IF frecvar↑.form = tagfwithid THEN tagf := frecvar↑.tagfieldp;
	    WHILE (fnextfld <> NIL) AND (fnextfld <> tagf) DO
		BEGIN
		newline;
		getfield(fnextfld);
		WITH fnextfld↑ DO
		    BEGIN
		    shifted_out(name);write(tty,'=');
		    chcnt:=chcnt+1;
		    nl := true;
		    leftspace:=leftspace+2;
		    writestructure(idtype);
		    leftspace:=leftspace-2;
		    fnextfld := next
		    END;
		IF fnextfld<>NIL THEN
		    WITH fnextfld↑.idtype↑ DO
			IF form=arrays THEN
			    BEGIN
			    getbounds(inxtype,lmin,lmax);
			    tabs:=arraypf AND tabs AND
			    comptypes(aeltype , entry1.charptr) AND
			    (lmax-lmin <= 20 )
			    END
			ELSE
			    tabs:=tabs AND (form<=pointer)
		ELSE
		    tabs:=false;
		gattr := lattr
		END (*WHILE*);
	    IF tagf <> NIL THEN
		BEGIN
		WITH tagf↑ DO
		    BEGIN
		    newline;
		    shifted_out(name);
		    write(tty,'=');
		    chcnt:=chcnt+1;
		    getfield( tagf );
		    j := nextbyte(idtype↑.bitsize);
		    writescalar(j, idtype);
		    write(tty,' (TAGFIELD)');
		    chcnt:=chcnt+11;
		    END;
		lsp := frecvar↑.fstvar;
		tabs:=false;
		LOOP
		    IF lsp = NIL THEN
			BEGIN
			write(tty,'(NO CORRESP.VARIANT)'); GOTO 1
			END
		EXIT IF lsp↑.varval.ival = j;
		    lsp := lsp↑.nxtvar
		    END (*LOOP*);
		WITH lsp↑ DO
		    BEGIN
		    IF form <> variant THEN
			system_error(6);
		    gattr := lattr;
		    writefieldlist( firstfield, subvar );
		    tabs:=false;
		    END;
	    1:
		END
	    END (*WRITEFIELDLIST*);

	BEGIN
	(*WRITESTRUCTURE*)
	IF fsp <> NIL THEN WITH fsp↑ DO
	    IF form <= pointer THEN  writescalar ( nextbyte(bitsize), fsp )
	    ELSE
		BEGIN
		lattr := gattr;
		WITH gattr DO
		    BEGIN
		    IF gbitcount > 0 THEN
			BEGIN
			gaddr := gaddr + 1; gbitcount := 0
			END;
		    CASE form OF
			power:
			    BEGIN
			    nocomma := true; write(tty, '['); leng := 1;
			    WITH setwandel DO
				BEGIN
				const1 := basis↑[gaddr]; const2 := basis↑[gaddr+1];
				FOR inx := 0 TO basemax DO
				    IF inx IN mask THEN
					BEGIN
					IF nocomma THEN nocomma := false
					ELSE write(tty,',');
					leng := leng + 1;
					IF comptypes(elset,entry1.charptr) THEN i := inx + offset
					ELSE i := inx;
					writescalar(i,elset)
					END
				END (*WITH SETWANDEL*);
			    write(tty,']' ); chcnt := chcnt + leng;
			    tabs:=false;
			    END (*POWER*);
			arrays:
			     BEGIN
			     illstring:=false;
			     getbounds(inxtype, lmin, lmax );
			     IF ( gaddr > ord(acrpoint(accus↑[0+15B],right)))  (* DYNAMIC ALLOCATED *)
				 AND ( gaddr <= ord(NIL) ) (* NOT A CONSTANT *) THEN
				 BEGIN
				 IF maxaddr > ord(accus) THEN maxaddr := ord(accus);
				 IF arraypf THEN
				     llmax := (maxaddr-gaddr+1) * (36 DIV aeltype↑.bitsize) + lmin - 1
				 ELSE
				     llmax := (maxaddr-gaddr+1) DIV aeltype↑.size  + lmin - 1;
				 IF llmax < lmax THEN lmax := llmax;
				 END;
			     leng := lmax - lmin + 1 ;
			     IF comptypes(aeltype , entry1.charptr) AND arraypf AND (leng<121) THEN
				 BEGIN
				 pointercv.addr := gaddr;
				 inx:=1;
				 WITH pointercv DO
				     WHILE (inx<=leng) DO
					 IF (stringptr↑[inx] < chr(40B (*' '*))) OR (stringptr↑[inx] > chr(172B (* LOWER-Z *))) THEN
					     inx:=122
					 ELSE inx:=inx+1;
				 IF inx = 122 THEN
				     BEGIN
				     illstring:=true;
				     write(tty,'STRING CONT. ILL. CHAR');
				     tabs:=false;
				     leftspace:=leftspace+2;
				     newline;
				     write(tty,'THE COMPONENTS ARE:');
				     nl:=true;
				     END;
				 END (* TEST ILLSTRING *);
			     IF comptypes(aeltype , entry1.charptr) AND arraypf AND (leng<121) AND NOT illstring THEN (*STRING*)
				 BEGIN
				 write ( tty,  '''',  pointercv.stringptr↑ : leng,  '''' ) ;
				 chcnt := chcnt + leng + 2;
				 tabs:= (leng <= 20);
				 END (*STRING*)
			     ELSE
				 BEGIN
				 tabs:=false;
				 packfg:=arraypf;
				 lasteq:=false;
				 FOR inx:= lmin TO lmax DO
				     BEGIN
				     IF inx=lmax THEN nexteq:=false
				     ELSE
					 IF aeltype↑.form <= pointer THEN
					     BEGIN
					     oattr:=gattr;
					     currcompo:=nextbyte(aeltype↑.bitsize);
					     nexteq:=currcompo = nextbyte(aeltype↑.bitsize);
					     gattr:=oattr;
					     END
					 ELSE
					     BEGIN
					     nexteq:=true;i:=0;
					     LOOP
						 nexteq:=(basis↑[gaddr+i] = basis↑[gaddr+aeltype↑.size+i]);
					     EXIT IF NOT nexteq OR (i = aeltype↑.size-1);
						 i:=i+1;
						 END;
					     END (* FORM>POINTER *);
				     IF NOT(lasteq AND nexteq) THEN
					 BEGIN
					 IF nl THEN newline
					 ELSE nl:=true;
					 write(tty,'['); writescalar(inx,inxtype);
					 write(tty,']'); chcnt:=chcnt+2;
					 END;
				     IF NOT nexteq THEN
					 BEGIN
					 write(tty,'=');chcnt:=chcnt+1;
					 leftspace:=leftspace + 3;
					 nl:=true;
					 writestructure(aeltype);
					 leftspace:=leftspace - 3;
					 END
				     ELSE
					 BEGIN
					 IF NOT lasteq THEN
					     BEGIN
					     write(tty,'..');
					     chcnt:=chcnt+2;
					     nl:=false;
					     END;
					 IF aeltype↑.form <= pointer THEN currcompo:=nextbyte(aeltype↑.bitsize)
					 ELSE gaddr:=gaddr+aeltype↑.size;
					 END (* NEXTEQ *);
				     lasteq:=nexteq;
				     END (* FOR *);
				 tabs:=false;
				 IF illstring THEN leftspace := leftspace - 2;
				 END (* NOT STRING *);
			     END (*ARRAYS*);
			records:
			      BEGIN
			      write(tty,'RECORD');
			      lspace := leftspace; leftspace := chcnt + 1;
			      tabs:=false;
			      writefieldlist(fstfld,recvar);
			      tabs:=false;
			      leftspace := leftspace - 1; newline;
			      write(tty,'END');
			      leftspace := lspace;
			      END;
			files:
			    WITH filblkwandel DO
				BEGIN
				IF nl THEN
				    newline;
				tabs:=true;
				int:=gaddr;
				WITH ptr↑, gattr  DO
				    IF (filpbh[left]=0) AND (filpbh[right]=0) THEN
					BEGIN
					write(tty,' FILE NOT OPENED');
					END
				    ELSE
					BEGIN
					shifted_out('DEVICE:   ');
					putsixbit(fildev,6);
					newline;
					shifted_out('NAME:     ');
					putsixbit(filnam,6);
					shifted_out('.         ');
					putsixbit(filext,3);
					newline;
					shifted_out('PPN:[     ');
					stinx:=1;
					LOOP
					    zero:=true;
					    FOR inx:=stinx TO stinx+5 DO
						IF NOT(zero AND (filppn[inx]=0)) OR (inx=stinx+5) THEN
						    BEGIN
						    zero:=false;
						    write(tty,chr(filppn[inx]+ord('0')));
						    chcnt:=chcnt+1;
						    END;
					EXIT IF stinx=7;
					    stinx:=7;write(tty,',');
					    END;
					write(tty,']');chcnt:=chcnt+2;
					newline;
					shifted_out('PROT:<    ');
					FOR inx:=1 TO 3 DO
					    write(tty,chr(filprot[inx]+60B));
					write(tty,'>');
					chcnt:=chcnt+4;
					newline;
					shifted_out('STATUS:   ');
					IF filsta=0 THEN shifted_out('ASCII     ')
					ELSE shifted_out('BINARY    ');
					newline;
					shifted_out('MODE(I/O):');
					IF filpbh[left]<>0 THEN shifted_out('OUTPUT    ')
					ELSE shifted_out('INPUT     ');
					newline;
					IF filpbh[left]=0 THEN
					    BEGIN
					    IF filsta=0 THEN
						BEGIN
						IF fillnr<>'-----' THEN
						    BEGIN
						    shifted_out('LINENR.:  ');
						    write(tty,fillnr);
						    chcnt:=chcnt+5;
						    newline;
						    END;
						write(tty,'EOLN:',fileol:5);
						chcnt:=chcnt+10;
						newline;
						END (* FILSTA = 0 *);
					    write(tty,'EOF:',(fileof<>0):5);
					    chcnt:=chcnt+9;
					    newline;
					    END (* FILPBH[LEFT]=0 *);
					gaddr:=filptr;
					typtr := typtr↑.filtype;
					tabs:=false;
					IF chcnt<>leftspace THEN newline;
					shifted_out('COMPONENT:');
					nl:=true;
					writestructure(typtr);
					END (* WITH PTR↑ *);
				tabs:=false;
				END (*  FILBLKWANDEL *)
			END (*CASE FORM*)
		    END (*WITH GATTR*);
		gattr := lattr;
		WITH gattr DO
		    BEGIN
		    gaddr := gaddr + size; gbitcount := 0
		    END
		END (*IF FORM > POINTER*)
	END (*WRITESTRUCTURE*);
	(** ASSIGNMENT **)

    PROCEDURE assignment;
	VAR
	    lattr: attr;
	    lsp: stp;
	    byte, i:  integer;
	BEGIN
	IF gattr.kind <> varbl THEN
	    BEGIN
	    error; writeln(tty,'ASSIGNMENT ALLOWED TO VARIABLES ONLY')
	    END
	ELSE
	    BEGIN
	    lattr := gattr;
	    expression;
	    IF sy <> eolsy THEN
		BEGIN
		error; writeln(tty,'<CR><LF> EXPECTED')
		END
	    ELSE
		IF comptypes( lattr.typtr, gattr.typtr ) THEN
		    BEGIN
		    IF (lattr.typtr <> NIL) AND (gattr.typtr <> NIL) THEN
			IF lattr.packfg THEN
			    BEGIN
			    load; byte := gattr.cval.ival;
			    gattr := lattr;
			    putnextbyte( gattr.typtr↑.bitsize, byte )
			    END (* IF PACKFG *)
			ELSE
			    IF gattr.kind <> varbl THEN basis↑[lattr.gaddr] := gattr.cval.ival
			    ELSE
				IF gattr.packfg THEN basis↑[lattr.gaddr] := nextbyte( gattr.typtr↑.bitsize )
				ELSE FOR i := 0 TO lattr.typtr↑.size - 1  DO
				    basis↑[lattr.gaddr + i ] := basis↑[ gattr.gaddr + i ]
		    END (* IF COMPTYPES *)
		ELSE
		    BEGIN
		    error; writeln(tty, 'TYPE-CONFLICT IN ASSIGNMENT' )
		    END
	    END (*  KIND=VARIABLE  *)
	END (*ASSIGNMENT*);

	(** STOPSEARCH PAGEVALUE LINEVALUE BREAKPOINT GETLINPAG **)

    FUNCTION stopsearch(fline:addrrange):integer;
	LABEL
	    1;
	VAR
	    i: integer;
	BEGIN
	FOR i := 1 TO stopmax DO WITH stoptable[i] DO
	    IF (page=gpage) AND (thisline=fline) THEN
		BEGIN
		stopsearch := i;
		GOTO 1(*EXIT*)
		END;
	stopsearch := 0; (*NOT FOUND*)
	1:
	END (*STOPSEARCH*);

    FUNCTION pagevalue(fpager: pageelem): integer;
	BEGIN
	WITH fpager DO  pagevalue := ac*16 + inxreg
	END (*PAGEVALUE*);

    FUNCTION linevalue ( VAR fliner: lineelem; fline: integer) : integer;
	LABEL
	    1;
	VAR
	    i: integer;
	BEGIN
	WHILE fliner.code = 260B(*PUSHJ*) DO
	    BEGIN
	    i := stopsearch( fline );
	    IF i = 0 THEN
		BEGIN
		writeln(tty,'$ STOPTABLE DESTROYED'); linevalue := -1; GOTO 1
		END;
	    fliner.constant1 := stoptable[i] . originalcont
	    END (*PUSHJ*);
	WITH fliner DO
	    IF code = 320B(*JUMP*) THEN  linevalue := fline - ( ac + 16*inxr )
	    ELSE (*SKIPA*)
		BEGIN
		IF code <> 334B(*SKIPA*) THEN
		    BEGIN
		    system_error(7);
		    linevalue := -1; GOTO 1
		    END;
		IF absline = 777777B THEN linevalue := -1
		ELSE linevalue := absline
		END;
	1:
	END (*LINEVALUE*) ;

    PROCEDURE breakpoint;
	LABEL
	    1;
	VAR
	    linenr, i: integer;
	    pager: pageelem;  lle: lineelem;
	    lline,lpage: integer;
	    oldline: integer;
	    oldaddr: ↑lineelem;
	    changeptr: ↑lineelem;

	FUNCTION getlinpag: boolean;  (*READS LINENUMBER AND PAGENUMBER*)
	    BEGIN
	    getlinpag := false;
	    IF sy <> intconst THEN writeln(tty,'$ ILL. LINENR.')
	    ELSE
		BEGIN
		linenr := val.ival; gpage := 1(*DEFAULT*);
		insymbol;
		IF sy = slashsy THEN
		    BEGIN
		    insymbol;
		    IF sy <> intconst THEN  writeln(tty,'$ ILL. PAGENR.')
		    ELSE
			BEGIN
			gpage := val.ival; insymbol
			END
		    END;
		IF sy <> eolsy THEN writeln(tty,'$ COMMAND ERROR')
		ELSE getlinpag := true
		END
	    END (*GETLINPAG*);

	BEGIN
	(*BREAKPOINT*)
	CASE sy OF
	    ident:
		IF id = 'LIST      ' THEN
		    BEGIN
		    insymbol;
		    IF sy <> eolsy THEN writeln(tty,'$ COMMAND ERROR')
		    ELSE FOR i := 1 TO stopmax DO  WITH stoptable[i] DO
			IF page > 0 THEN writeln(tty,'$ ', thisline:5, '/', page:length(page))
		    END
		ELSE
		    writeln(tty,'$ COMMAND ERROR');
	    notsy:
		BEGIN
		insymbol;
		IF getlinpag THEN
		    BEGIN
		    i:=stopsearch(linenr);
		    IF i = 0 THEN writeln(tty, '$ ?NO STOP')
		    ELSE WITH stoptable[i] DO
			BEGIN
			page := 0;
			protection(false);
			thisaddr↑.constant1 := originalcont;
			protection(true);
			thisaddr := NIL
			END
		    END
		END;
	    intconst:
		   IF getlinpag  AND  ( stopsearch(linenr) = 0 (*A NEW STOP*) ) THEN
		       BEGIN
		       stopnr := 1;
		       WHILE stoptable[stopnr].page <> 0 DO  stopnr := stopnr + 1;
		       IF stopnr > stopmax THEN writeln(tty,'$ TOO MUCH STOPS')
		       ELSE
			   BEGIN
			   (*EXECUTE STOP*)
			   (*1.STEP: SEARCH PAGE*)
			   pager := entry1.lastpageelem;
			   lpage := pagevalue(pager);
			   IF lpage < gpage THEN writeln(tty,'$ PAGENR. TOO LARGE')
			   ELSE
			       BEGIN
			       WHILE  lpage > gpage  DO
				   BEGIN
				   pager := pager.pagptr↑;
				   lpage := pagevalue(pager)
				   END;
			       IF lpage <> gpage THEN
				   BEGIN
				   writeln(tty,'$ CAN''T STOP ON THIS PAGE'); GOTO 1
				   END;
			       WITH lle, pager DO
				   BEGIN
				   lline := lastline; adp := laststop
				   END;
			       IF lline < linenr THEN writeln(tty,'$ LINENR. TOO LARGE')
			       ELSE
				   BEGIN
				   WHILE lline > linenr DO
				       BEGIN
				       oldline := lline; oldaddr := lle.adp;
				       lle := lle.adp↑;
				       lline := linevalue ( lle, lline )
				       END;
				   IF lline <> linenr THEN
				       BEGIN
				       write(tty,'$ NEXT POSSIBLE: ',oldline:length(oldline),' (Y OR N)? ');
				       break; readln(tty);
				       insymbol;
				       IF (sy <> ident) OR (id[1] <> 'Y') OR (stopsearch(oldline) <> 0) THEN GOTO 1;
				       lle.adp := oldaddr; lline := oldline
				       END;
				   changeptr := lle.adp;
				   WITH stoptable[stopnr] DO
				       BEGIN
				       thisline := lline;  page := gpage;
				       originalcont := changeptr↑.constant1;
				       thisaddr := changeptr
				       END;
				   protection(false);
				   changeptr↑.constant1 := entry2.stoppy;
				   protection(true)
				   END
			       END
			   END;
	1:
		       END (*INTCONST*);
	    OTHERS:
		 writeln(tty,'$ COMMAND ERROR')
	    END (*CASE*)
	END (*BREAKPOINT*);
	(** LINEINTERVAL STOPMESSAGE TRACEOUT ONE_VAR_OUT **)

    PROCEDURE lineinterval(faddr: addrrange; VAR lin1,lin2,pag: integer);
	VAR
	    pager: pageelem; liner: lineelem;
	BEGIN
	pager := entry1.lastpageelem;
	WHILE ord(pager.pagptr) > faddr DO
	    pager := pager.pagptr↑;
	liner.adp := pager.laststop;
	pag := pagevalue(pager); lin2 := pager.lastline;
	lin1 := lin2;
	WHILE ord ( liner.adp ) > faddr DO
	    BEGIN
	    liner := liner.adp↑;

	    lin2 := lin1;
	    lin1 := linevalue(liner,lin2)
	    END;
	IF lin1<0 THEN lin1 := 0
	END (*LINEINTERVAL*);

    PROCEDURE stopmessage(faddr: addrrange);
	VAR
	    lin1, lin2, pag: integer;
	BEGIN
	lineinterval(faddr,lin1,lin2,pag);
	writeln(tty, '$ STOP IN ', lin1:length(lin1), '/', pag:length(pag), ':',lin2:length(lin2) )
	END (*STOPMESSAGE*) ;

    PROCEDURE traceout;
	VAR
	    i: 0:5; lcp: ctp;
	    laddr: addrrange;
	    lin1, lin2, pag, maxnames: integer;
	BEGIN
	tabs:=false;
	IF dump THEN
	    BEGIN
	    newline;
	    writeln(tty,' ':39,'PROCEDURE BACKTRACING');
	    write(tty,'$',' ':40,'=====================');
	    newline;
	    writeln(tty);maxnames:=5;
	    END
	ELSE
	    maxnames:=2;
	firstbasis; i := 0; leftspace := 0;
	laddr := entry2.status.returnaddr;
	write(tty,'$ ');
	LOOP
	    lineinterval (  laddr, lin1,  lin2, pag  ) ;
	    write(tty,lin1:5,'/',pag:length(pag),' ')
	EXIT IF basis = nullptr;
	    lcp := idtree;
	    IF lcp<>NIL THEN
		write(tty, lcp↑.next↑.name )
	    ELSE
		write(tty,'''NO NAME'' ');
	    IF i = maxnames THEN
		BEGIN
		newline; i := 0
		END
	    ELSE
		BEGIN
		write(tty,' _ '); i := i + 1
		END;
	    laddr := ord ( acrpoint(basis↑[0]-1,right) );
	    succbasis( left(*=DYNAMIC*) )
	    END;
	writeln(tty, 'MAIN')
	END (*TRACEOUT*);


    PROCEDURE one_var_out(lcp:ctp);
	BEGIN
	WITH lcp↑,gattr DO
	    BEGIN
	    kind:=varbl;
	    gaddr:=vaddr+ord(merkbasis);
	    gbitcount:=0;
	    IF vkind=formal THEN
		gaddr:=nullptr↑[gaddr];
	    typtr:=idtype;
	    packfg:=false;
	    shifted_out(name);
	    write(tty,'=');
	    chcnt:=chcnt+1;
	    IF idtype↑.form > power THEN
		BEGIN
		nl:=true;
		leftspace:=2;
		END;
	    writestructure(idtype);
	    IF idtype↑.form >= power THEN
		BEGIN
		leftspace:=0;
		tabs:=false;
		newline;
		END;
	    newline;
	    END (* WITH *);
	END (* ONE_VAR_OUT *);
	(** SECTION_OUT OUT **)

    PROCEDURE section_out(lcp:ctp;fformset:formset);
	BEGIN
	WITH lcp↑ DO
	    BEGIN
	    IF llink<>NIL THEN
		section_out(llink,fformset);
	    IF (klass=vars) AND (idtype↑.form IN fformset) THEN
		one_var_out(lcp);
	    IF rlink<>NIL THEN
		section_out(rlink,fformset);
	    END (* WITH *);
	END (* SECTION_OUT *);

    PROCEDURE out(side:leftorright);
	VAR
	    callcnt:integer;
	    treepnt:ctp;
	    lowestdynamicbasis,staticbasis:acr;
	    varsout:boolean;
	BEGIN
	callcnt:=1;
	chcnt:=0;
	tabs:=false;
	lowestdynamicbasis:=merkbasis;
	firstbasis;
	staticbasis:=basis;
	LOOP
	    merkbasis:=basis;
	    treepnt:=idtree;
	    basis:=nullptr;
	    varsout:=true;
	    IF merkbasis=nullptr THEN
		write(tty,' * * * * * * * *  MAIN')
	    ELSE
		IF treepnt=NIL THEN
		    write(tty,'P R O C E D U R E  ''NO NAME'' ')
		ELSE
		    IF treepnt↑.next <> NIL THEN
			IF treepnt↑.next↑.klass = func THEN write(tty,'F U N C T I O N  ',treepnt↑.next↑.name)
			ELSE write(tty,'P R O C E D U R E  ',treepnt↑.next↑.name);
	    newline;
	    write(tty,'- - - - - - - - - - - - - - - -');
	    newline;
	    IF (side = left) AND (staticbasis = merkbasis) AND (merkbasis <> nullptr) THEN
		BEGIN
		write(tty,'THE FOLLOWING VARIABLES ARE VALID');newline;
		write(tty,' IN THE INTERRUPTED PROCEDURE ');
		newline;newline;
		basis:=staticbasis;
		succbasis(right);
		staticbasis:=basis;
		basis:=nullptr;
		END
	    ELSE
		IF (side = right) AND (ord(lowestdynamicbasis) <= ord(merkbasis)) THEN
		    BEGIN
		    write(tty,'LOOK ABOVE ( VAR. OF CALLED PROC.) ');
		    newline; varsout:=false;
		    END;
	    IF (treepnt = NIL) AND varsout THEN
		BEGIN
		write(tty,' THERE IS NO INFORMATION ABOUT' );newline;
		write(tty,'  THIS PART OF THE PROGRAMM ( LOCAL D- ??)');
		newline; varsout:=false;
		END (* TREEPTR=NIL ....*);
	    IF varsout AND (merkbasis<>nullptr) THEN treepnt:=treepnt↑.llink;
	    IF varsout THEN
		IF treepnt<>NIL THEN
		    BEGIN
		    section_out(treepnt,[scalar,subrange,pointer]);
		    tabs:=false;
		    IF chcnt<>0 THEN newline;
		    newline;
		    section_out(treepnt,[power,arrays,records,files]);
		    tabs:=false;
		    END (* TREEPNT<>NIL *)
		ELSE
		    BEGIN
		    write(tty,'+++ NO VARIABLES +++');
		    newline;newline;
		    END;
	    newline;newline;
	EXIT IF (merkbasis=nullptr) OR (callcnt=10);
	    callcnt:=callcnt+1;
	    basis:=merkbasis;
	    succbasis(side);
	    END (* LOOP *);
	IF merkbasis=nullptr THEN
	    section_out(entry1.standardidtree,[files]);
	END (* OUT *);
	(** STACK_OUT HEAP_OUT **)

    PROCEDURE stack_out;
	BEGIN
	newline;newline;
	writeln(tty,' ':40,'VARIABLES OF THE CALLED PROCEDURE(S)');
	write(tty,'$',' ':41,'====================================');
	newline;newline;
	out(left);
	IF merkbasis<>nullptr THEN
	    BEGIN
	    newline;newline;
	    write(tty,' BECAUSE THERE ARE MORE THAN 10 DYNAMIC NESTED PROCEDURES AND/OR FUNCTIONS');
	    newline;
	    write(tty,' NOW ONLY THE VARIABLES OF THE STATIC NESTED PROCEDURES AND/OR FUNCTIONS ');
	    newline;write(tty,' WILL BE PRINTED OUT');newline;
	    newline;newline;newline;
	    writeln(tty,' ':40,'VARIABLES OF STATIC NESTED PROCEDURES');
	    write(tty,'$',' ':41,'=====================================');
	    newline;newline;newline;
	    out(right);
	    END (*BASIS<>.. *);
	END (* ALL_VAR_OUT *);

    PROCEDURE heap_out;
	VAR
	    rec:acr;

	BEGIN
	newline;
	writeln(tty,' ':39,'THE CONTENTS OF THE HEAP');
	write(tty,'$ ',' ':39,'========================');
	newline;
	tabs:=false;
	rec:=acrpoint(accus↑[0+15B],right);
	WITH heapcv DO
	    BEGIN
	    cival:=rec↑[0];
	    IF (cidtype=NIL) AND (cacr=NIL) THEN
		BEGIN
		newline;
		write(tty,' NO VARIABLES ALLOCATED');
		newline;
		END
	    ELSE
		WHILE cacr<>NIL DO
		    BEGIN
		    IF (ord(cacr) > ord(accus)) OR
			(ord(cacr) <= accus↑[0+15B])  OR
			(ord(cacr)  <= ord(rec)) OR
			(ord(cidtype) < ord(NIL))  OR
			(ord(cidtype) > ord(entry2.entryptr)) THEN
			BEGIN
			newline;
			write(tty,' CANT CONTINUE THE HEAP-DUMP');
			cacr:=NIL;
			newline;
			END
		    ELSE
			BEGIN
			newline;
			write(tty,(ord(rec)+1):6:o,'B↑=');
			chcnt:=chcnt+9;
			IF cidtype=NIL THEN
			    BEGIN
			    newline;
			    write(tty,' TYPE OF REFERENCED VARIABLE NOT KNOWN');
			    newline;
			    END
			ELSE
			    WITH gattr DO
				BEGIN

				nl:=true;
				typtr:=cidtype;
				kind:=varbl;
				packfg:=false;
				gaddr:=ord(rec)+1;
				maxaddr:=ord(cacr) - 1;
				gbitcount:=0;
				writestructure(cidtype);
				END (* WITH GATTR *);
			tabs:=false;
			rec:=cacr;
			cival:=rec↑[0];
			newline;
			END (* POINTER OK *);
		    END (* WHILE *);
	    END (* WITH HEAPCV *);
	newline;
	END (* HEAP_OUT *);
	(** WRITE_PROGRAM_NAME HEADER BACK_TO_TTY CORRECT_ADDR RIGHT_ADDR **)

    PROCEDURE write_program_name;
	BEGIN
	WITH pointercv DO
	    BEGIN
	    addr := ord(acrpoint(entry2.name_pnt_pnt↑[0],right));
	    shifted_out(alfapnt↑);
	    END;
	writeln(tty)
	END (* WRITE_PROGRAM_NAME *);

    PROCEDURE header;
	BEGIN
	leftspace:=0;
	dump:=true;
	time(day_time);
	date(day);
	file_name:='      PMD';
	file_name[1]:=day_time[1];
	file_name[2]:=day_time[2];
	file_name[3]:=day_time[4];
	file_name[4]:=day_time[5];
	file_name[5]:=day_time[7];
	file_name[6]:=day_time[8];
	IF entry2.interactive THEN
	    device:='DSK   '
	ELSE device:='LPT   ';
	rewrite(ttyoutput,file_name,0,0,device);
	newline;
	write(tty,day:20,day_time:20,'PROGRAM-NAME ':20);
	write_program_name;
	write(tty,'$ ');
	END (* HEADER *);

    PROCEDURE back_to_tty;
	BEGIN
	tabs:=false;
	dump := false;
	rewrite(ttyoutput,'123456789',0,0,'TTY   ');
	IF entry2.interactive THEN write(tty,'$');
	newline;
	newline;
	writeln(tty,'LOOK FOR DUMP ON FILE ',file_name:6,
		'.',file_name[7],file_name[8],file_name[9]);
	END (* BACK_TO_TTY *);


    PROCEDURE correct_addr;
	VAR
	    pagepointer:↑pageelem;

	FUNCTION right_addr:addrrange;
	    VAR
		help:integer;
		lacr:acr;
	    BEGIN
	    firstbasis;
	    IF basis=nullptr THEN right_addr:=ord(acrpoint(entry2.stackbottom↑[0+2]-1,right))
	    ELSE
		BEGIN
		lacr:=acrpoint(basis↑[0]-1,right);
		help:=lacr↑[0];
		REPEAT
		    help:=help+1;
		    lacr:=acrpoint(help,right);
		UNTIL ord(acrpoint(lacr↑[0],left))=541757B (*HRRI 17,?(17)*);
		help:=ord(acrpoint(lacr↑[0],right));
		right_addr:=ord(acrpoint(basis↑[help+1]-1,right));
		END;
	    END (* RIGHT_ADDR *);

	BEGIN
	WITH entry1,entry2.status DO
	    BEGIN
	    IF ord(entry2.entryptr) <= returnaddr THEN
		returnaddr:=right_addr
	    ELSE
		BEGIN
		pagepointer:=lastpageelem.pagptr;
		IF ord(pagepointer)  <> 0 THEN
		    WHILE ord(pagepointer↑.pagptr) <> 0  DO
			pagepointer:=pagepointer↑.pagptr;
		IF  (ord(pagepointer) > returnaddr) OR ( ord(pagepointer)  = 0 ) THEN
		    returnaddr:=right_addr;
		END (* ELSE *);
	    END (* WITH *);
	END (* CORRECT_ADDR *);

	(** INIT DEBUG_INTERACTIVE **)

    PROCEDURE init;
	BEGIN
	WITH pointercv DO
	    BEGIN
	    addr := 140B;
	    entry2 := entptr2↑
	    END;
	entry1 := entry2.entryptr↑;
	accus := entry2.registrs;
	nullptr := acrpoint(0,right);
	IF entry2.status.kind IN [ddtk,runtmerrk] THEN correct_addr;
	laddr := entry2.status.returnaddr;
	END (*INIT*);

    PROCEDURE debug_interactive;
	LABEL
	    1;
	VAR
	    open_tty: boolean;
	BEGIN
	writeln(tty);
	break;
	open_tty := true;
	CASE entry2.status.kind  OF
	    initk:
		BEGIN
		id := 'TTY       '; variable; (*FILEBLOCK(TTY)-->GATTR*)
		IF basis↑[gattr.gaddr+13B] = 0 THEN
		    open_tty := false;
		(* TO BE SURE THAT THE TTY-INPUT FILE HAS BEEN OPENED *)
		write(tty, version:5,': ');
		write_program_name;
		END;
	    stopk:
		BEGIN
		FOR stopnr := 1 TO stopmax DO
		    WITH stoptable[stopnr] DO
			IF ord(thisaddr) = laddr THEN
			    BEGIN
			    write(tty,'$ STOP AT ', thisline:length(thisline), '/', page:length(page),' IN ');
			    write_program_name;
			    GOTO 1
			    END;
		stopmessage(laddr); (*,IF NOT FOUND*)
	1:
		END;
	    ddtk:
	       BEGIN
	       write(tty, '$ STOP BY DDT COMMAND IN ');
	       write_program_name;
	       stopmessage(laddr)
	       END;
	    haltk, runtmerrk:
			   BEGIN
			   IF entry2.status.kind = runtmerrk THEN
			       write(tty,'$ STOP BY RUNTIME ERROR IN ')
			   ELSE
			       write(tty,'$ STOP BY HALT IN ');
			   write_program_name;
			   stopmessage(laddr)
			   END
	    END (*CASE*);
	bufflng := 0;
	WHILE NOT eoln(tty) AND open_tty  DO
	    BEGIN
	    bufflng := bufflng + 1;
	    (*READ ( TTY, BUFFER[BUFFLNG] )*) buffer[bufflng] := tty↑; get(tty)
	    END;
	REPEAT
	    REPEAT
		write(tty,'$'); break;
		IF open_tty THEN readln(tty)
		ELSE
		    BEGIN
		    open_tty := true;
		    reset(tty,'TTY      ',0,0,'TTY   ');
		    END;
	    UNTIL NOT eoln(tty);
	    read(tty,ch); chcnt := 0;
	    insymbol;
	    CASE sy OF
		stopsy:
		     BEGIN
		     insymbol;
		     breakpoint
		     END;
		stackdumpsy,
		heapdumpsy:
			 BEGIN
			 header;
			 writeln(tty);
			 stopmessage(laddr);
			 write(tty,'$');
			 newline;
			 traceout;
			 write(tty,'$ ');
			 IF sy=stackdumpsy THEN stack_out
			 ELSE heap_out;
			 back_to_tty;
			 END;
		tracesy:
		      traceout;
		ident, notsy,    (*EXPRESSION-BEGIN-SYMBOLS*)
		intconst, realconst, charconst, stringconst, plus, minus,
		lparent:
		      BEGIN
		      expression;
		      CASE sy OF
			  eqsy:
			     WITH gattr DO
				 IF typtr <> NIL THEN
				     BEGIN
				     write(tty,'$ ');
				     chcnt := 0; leftspace := 0;  nl := false;
				     IF kind <> varbl THEN
					 IF typtr↑.form = arrays THEN
					     BEGIN
					     gaddr := cval.ival;
					     basis := nullptr;
					     writestructure ( typtr )
					     END
					 ELSE writescalar(cval.ival,typtr)
				     ELSE writestructure( typtr );
				     writeln(tty)
				     END;
			  becomes:
				BEGIN
				insymbol; assignment
				END;
			  OTHERS:
			       BEGIN
			       error; writeln(tty, '"=" OR ":=" EXPECTED')
			       END
			  END (*CASE*)
		      END;
		endsy, eolsy: (*EMPTY*) ;
		OTHERS:
		     writeln(tty,'$ COMMAND ERROR')
		END (*CASE*)
	UNTIL sy=endsy;
	IF entry2.status.kind IN [runtmerrk,haltk] THEN writeln(tty,'$ CANNOT CONTINUE')
	ELSE
	    BEGIN
	    WHILE sy <> eolsy DO insymbol;
	    IF (bufflng > 0) AND (entry2.status.kind <> ddtk) THEN WITH gattr DO
		BEGIN
		id := 'TTY       '; variable; (*FILEBLOCK(TTY)-->GATTR*)
		basis↑[gaddr+25B(*FILCMP*)] := ord(buffer[1]);
		basis↑[gaddr+ 2B(*FILEOL*)] := ord(false);
		basis↑[gaddr+22B(*FILBTC*)] := bufflng + 2;
		laddr := basis↑[gaddr+20B(*FILBFH*)]+2; (*ADDR OF 1ST DATA*)
		basis↑[gaddr+21B(*FILBTP*)] := 010700000000B + laddr -1;
		gaddr := laddr; packfg:= true;
		FOR chcnt := 2 TO bufflng DO  putnextbyte(7,ord(buffer[chcnt]));
		putnextbyte(7,015B); putnextbyte(7,012B); (*<CR><LF>*)
		FOR chcnt := 1 TO 4 DO  putnextbyte(7,0);
		(*CLEAR WITH NULL*)
		writeln(tty,'$ INPUT RESCANNED(!) : ', buffer:bufflng);
		break
		END;
	    writeln(tty)
	    END
	END (*DEBUG_INTERACTIVE*);

	(** DEBUG_BATCH ] DEBUG **)

    PROCEDURE debug_batch;

	BEGIN
	CASE entry2.status.kind OF
	    initk:
		WITH pointercv DO
		    BEGIN
		    write(tty,version:5,': ');
		    write_program_name;
		    addr:=140B;
		    entptr2↑.time_limit:= 4 * ((entry2.time_limit + clock) DIV 5);
		    break;
		    END;
	    haltk, runtmerrk:
			   BEGIN
			   header;
			   newline;
			   newline;
			   writeln(tty,'***************************************************':90);
			   writeln(tty,'$','*':41,'*':50);
			   writeln(tty,'$','*':41,'*':50);
			   writeln(tty,'$','*':41,' P O S T - M O R T E M - D U M P        *':51);
			   writeln(tty,'$','*':41,version:34,'*':16);
			   writeln(tty,'$','*':41,'*':50);
			   writeln(tty,'$','***************************************************':91);
			   write(tty,'$');
			   newline;
			   writeln(tty);
			   stopmessage(laddr);
			   write(tty,'$ ');
			   IF entry2.status.kind = haltk THEN write(tty,'STOP BY HALT')
			   ELSE write(tty,'STOP BY RUNTIME ERROR');
			   newline;
			   newline;
			   traceout;
			   write(tty,'$');
			   stack_out;
			   newline;
			   heap_out;
			   write(tty,'   END  OF  POST - MORTEM - DUMP');
			   back_to_tty;
			   END;
	    OTHERS:
		 writeln(tty,'$  POST-MORTEM-DUMP ERROR')
	    END;
	END;

	(*!!!!!!!!!!!!!!!!!!!!!! DEBUG !!!!!!!!!!!!!!!!!!!!!!!!*)
    BEGIN
    init;
    IF entry2.interactive THEN
	debug_interactive
    ELSE
	debug_batch;
    END (*debug*);
BEGIN
END.

PROGRAM status, getstatus;

    (*******************************************************************************
     *
     *   PASCAL RUNTIME SYSTEM (29-JUL-76,KISICKI)
     *
     *   PROCEDURE GETSTATUS
     *
     *    - ASSIGN APPROPRIATE VALUES TO
     *      "FILENAME", "PROTECTION", "UFD" AND "DEVICE"
     *      AS FOUND IN  "FILE_BLOCK".
     *
     *      GETSTATUS IS A PRE-DECLARED PROCEDURE AND AVAILABLE TO
     *      EVERY PASCAL USER.
     *
     ******************************************************************************)

TYPE
    leftorright = (left,right);
    ascii = PACKED ARRAY[1..5] OF char;
    pack6 = PACKED ARRAY[1..6] OF char;
    pack9 = PACKED ARRAY[1..9] OF char;
    threebit = PACKED ARRAY[1..12] OF 0..7;
    halfword = PACKED ARRAY[leftorright] OF 0..777777B;
    sixbit = PACKED ARRAY[1..6] OF 0..77B;
    fileblockpointer = ↑fileblock;
    fileblock = RECORD
		    fileof,filptr:integer;
		    fileol:boolean;
		    filsta,filcls,filout,filin,filent,
		    fillkp,filopn:integer;
		    fildev:sixbit;
		    filpbh:halfword;
		    filext,filnam:sixbit;
		    filprot:threebit;
		    filppn: integer;
		    filbtc,filbtp,filbfh:integer;
		    fillnr:ascii;
		    filcmp,filcnt:integer
		END;

PROCEDURE getstatus(file_block: fileblockpointer;
		    VAR filename: pack9;
		    VAR protection, ufd: integer;
		    VAR device: pack6);
    VAR
	i: integer;

    BEGIN
    (*GETSTATUS*)
    WITH file_block↑ DO
	BEGIN
	ufd := filppn;
	protection := 0;
	FOR i := 1 TO 3 DO protection := protection*10B + filprot[i];
	FOR i := 1 TO 6 DO filename[i] := chr(filnam[i] + 40B);
	FOR i := 1 TO 3 DO filename[i+6] := chr(filext[i] + 40B);
	FOR i := 1 TO 6 DO device[i] := chr(fildev[i] + 40B)
	END
    END (*GETSTATUS*);

BEGIN
END.

PROGRAM read, readscalar, readirange,
    readcrange, readrrange, readiset, readcset, readdset, readstr;

    (************************************************************************************
     *
     *  (C) COPYRIGHT 1978, 1979
     *          BOARD OF TRUSTEES
     *          LELAND STANFORD JUNIOR UNIVERSITY
     *              STANFORD, CA. 94305, U. S. A.
     *
     *      (C) COPYRIGHT 1978, 1979
     *          ARMANDO R. RODRIGUEZ
     *              LOTS COMPUTER FACILITY
     *              STANFORD UNIVERSITY
     *              STANFORD, CA. 94305, U. S. A.
     *
     *   (C) COPYRIGHT H.-H. NAGEL
     *                 INSTITUT FUER INFORMATIK
     *                 DER UNIVERSITAET HAMBURG
     *                 SCHLUETERSTRASSE 70
     *                 2000 HAMBURG 13
     *                 GERMANY
     *                 1976
     *
     *   PASCAL RUNTIME SYSTEM
     *          (FROM KISICKI, 29-JUL-76)
     *
     *   EXTENDED FORMATTED INPUT
     *
     *      - READSCALAR   :  READ IDENTIFIERS OF DECLARED SCALARS
     *
     *      - READIRANGE,
     *        READCRANGE,
     *        READRRANGE   :  READ SUBRANGE OF INTEGER, CHAR OR REAL
     *                        WITH BOUNDARY CHECKS
     *
     *      - READISET,
     *        READCSET,
     *        READDSET     :  READ SETS OF INTEGER, CHAR OR DECLARED SCALARS
     *                        OR THEIR SUBRANGES WITH BOUNDARY CHECKS
     *
     *      - READSTR      : READ A 'STRING' AS DEFINED IN THE NON-STANDARD
     *                       STRING PACKAGE. NOT NEEDED IF THE PACKAGE IS
     *                       DEACTIVATED.
     *
     *          NOTICE THAT, TO AVOID EATING MORE CHARACTERS THAN NEEDED,
     *          THE PROCEDURES ARE USING NEXTCH, THAT WORKS LIKE READ,
     *          BUT BACKWARDS, THAT IS, IT FIRST GETS AND THEN ASSIGNS.
     *
     ************************************************************************************)

CONST
    maxset = 71;
    offset = 40B;
    maxstrlen = 135;

TYPE
    setrange = 0..maxset;
    vector = ↑name_vector;
    name_vector = ARRAY[0..0] OF alfa;
    standard_set = SET OF setrange;
    scalar_form = (integer_form,char_form,real_form,bool_form,declared_form,sstring_form);
    error_form = (nonalpha,undefined,outofrange,doublydef,nonnumeric,openquote,
		  doublequote,closequote,twoperiods,openbracket,
		  closebracket,endoffile,endofline,toolongstr);
    string = RECORD
		 strtext: PACKED ARRAY[1..maxstrlen] OF char;
		 len: 0..maxstrlen;
	     END;

VAR
    type_name: PACKED ARRAY[scalar_form,1..7] OF char;
    errormessage: PACKED ARRAY[error_form,1..25] OF char;
    ch: char;
    set_flag, direct_call, error_exit: boolean;
    identifier: alfa;

INITPROCEDURE;
    BEGIN
    type_name[integer_form]  := 'INTEGER';
    type_name[char_form]     := 'CHAR   ';
    type_name[real_form]     := 'REAL   ';
    type_name[bool_form]     := 'BOOLEAN';
    type_name[declared_form] := 'SCALAR ';
    type_name[sstring_form]  := 'STRING ';
    errormessage[nonalpha    ] := 'STARTS WITH NONALPHABETIC';
    errormessage[undefined   ] := 'UNDEFINED OR OUT OF RANGE';
    errormessage[outofrange  ] := 'VALUE OUT OF THE RANGE   ';
    errormessage[doublydef   ] := 'SET ELEMENT APPEARS TWICE';
    errormessage[nonnumeric  ] := 'IT STARTS WITH NONNUMERIC';
    errormessage[openquote   ] := 'OPENING QUOTE EXPECTED   ';
    errormessage[doublequote ] := 'QUOTE SHOULD BE DOUBLE   ';
    errormessage[closequote  ] := 'CLOSING QUOTE EXPECTED   ';
    errormessage[twoperiods  ] := 'TWO PERIODS EXPECTED     ';
    errormessage[openbracket ] := 'OPENING BRACKET EXPECTED ';
    errormessage[closebracket] := ''','',''..'' OR '']'' EXPECTED ';
    errormessage[endoffile   ] := 'READ ATTEMPTED BEYOND EOF';
    errormessage[endofline   ] := 'EOLINE WHEN CHAR EXPECTED';
    errormessage[toolongstr  ] := 'LINE EXCEEDS MAX LENGTH, ';
    direct_call := true; error_exit := false; set_flag := false;
    END;
	(** STOP ERROR NEXTCH SKIP READIRANGE READCRANGE READRRANGE **)

PROCEDURE stop; EXTERN;

PROCEDURE wrtfnm(VAR source_file: text); EXTERN;

PROCEDURE writefilename(VAR source_file: text);
    BEGIN (*WRITEFILENAME*)
    error_exit := false;
    write(tty,' IN FILE ');
    break(tty);
    wrtfnm(source_file);
    END (*WRITEFILENAME*);

PROCEDURE error( errornumber: error_form; type_form: scalar_form);
    BEGIN (*ERROR*)
    IF NOT error_exit THEN
	BEGIN
	writeln(tty);
	write(tty,'%?      INPUT ERROR: READING A ');
	IF set_flag THEN
	    write(tty,'SET OF ');
	IF type_form <> sstring_form THEN
	    write(tty,'SUBRANGE OF ');
	writeln(tty,type_name[type_form],' :');
	write(tty,' ':8);
	error_exit := true
	END;
    write(tty,errormessage[errornumber]);
    break(tty);
    END (*ERROR*);

PROCEDURE nextch( VAR source_file: text);
    BEGIN (*NEXTCH*)
    get(source_file);
    ch := source_file↑;
    END (*NEXTCH*);

PROCEDURE skip( VAR source_file: text);
    BEGIN   (*SKIP*)
    ch := source_file↑;
    LOOP
	WHILE (ch = ' ') AND NOT eoln(source_file) DO
	    nextch(source_file);
    EXIT IF (ch <> ' ') OR eof(source_file);
	readln(source_file);
	ch := source_file↑;
	END
    END (*SKIP*);

PROCEDURE readirange( VAR source_file: text;
		     VAR source_value: integer;
		     min_value, max_value: integer);
    VAR
	negative: boolean;

    BEGIN (*READIRANGE*)

    IF direct_call THEN skip(source_file);

    negative := false; source_value := 0;
    IF ch IN ['+','-'] THEN
	BEGIN
	negative := ch = '-';
	nextch(source_file)
	END;

    IF NOT (ch IN ['0'..'9']) THEN
	BEGIN
	error(nonnumeric,integer_form);
	writeln(tty,' ***',ch,'***');
	write(tty,' ':7);
	END;

    WHILE ch IN ['0'..'9'] DO
	BEGIN
	source_value := source_value * 10 + (ord(ch) - ord('0'));
	nextch(source_file)
	END;

    IF NOT error_exit THEN
	BEGIN
	IF negative THEN
	    source_value := - source_value;
	IF (source_value < min_value) OR (source_value > max_value) THEN
	    BEGIN
	    error(outofrange,integer_form);
	    writeln(tty,' ',min_value,'..',max_value,' ***',source_value,'***');
	    write(tty,' ':7);
	    END;
	END;
    IF direct_call AND error_exit THEN
	BEGIN
	writefilename(source_file);
	stop
	END
    ELSE
	direct_call := true
    END (*READIRANGE*);

PROCEDURE readcrange( VAR source_file: text;
		     VAR source_value: char;
		     min_value, max_value: char);
    BEGIN (*READCRANGE*);
    IF eoln(source_file) THEN
	BEGIN
	IF NOT direct_call THEN
	    BEGIN
	    error(endofline,char_form);
	    writeln(tty);
	    write(tty,' ':7);
	    END
	ELSE
	    BEGIN
	    readln(source_file);
	    ch := source_file↑;
	    END;
	END;
    IF NOT error_exit THEN
	BEGIN
	source_value := source_file↑;
	get(source_file);
	IF (source_value < min_value) OR (source_value > max_value) THEN
	    BEGIN
	    error(outofrange,char_form);
	    writeln(tty,' ''',min_value,'''..''',max_value,''' ***''',source_value,'''***');
	    write(tty,' ':7);
	    END;
	END;
    IF direct_call AND error_exit THEN
	BEGIN
	writefilename(source_file);
	stop
	END
    ELSE
	direct_call := true
    END (*READCRANGE*);

PROCEDURE readrrange( VAR source_file: text;
		     VAR source_value: real;
		     min_value, max_value: real);
    BEGIN (*READRRANGE*)
    skip(source_file);
    read(source_file,source_value);
    IF (source_value < min_value) OR (source_value > max_value) THEN
	BEGIN
	error(outofrange,real_form);
	writeln(tty,' ',min_value,'..',max_value);
	write(tty,' ':8,'***',source_value,'***');
	IF direct_call THEN
	    BEGIN
	    writefilename(source_file);
	    stop
	    END
	END;
    direct_call := true
    END (*READRRANGE*);
	(** READSCALAR READIDENTIFIER READSET **)

PROCEDURE readscalar( VAR source_file: text;
		     VAR source_value: integer;
		     min_value, max_value: integer;
		     scalar_name: vector);

    PROCEDURE readidentifier;
	VAR
	    i: integer;

	BEGIN (*READIDENTIFIER*)
	identifier := '          '; i := 0;
	IF NOT (ch IN ['A'..'Z']) THEN
	    BEGIN
	    error(nonalpha,declared_form);
	    writeln(tty,'. SUBRANGE IS ',scalar_name↑[min_value],'..',scalar_name↑[max_value]);
	    write(tty,'***':11,ch,'***');
	    END
	ELSE
	    REPEAT
		IF i < alfalength THEN
		    BEGIN
		    i := i + 1;
		    identifier[i] := ch;
		    END;
		nextch(source_file)
	    UNTIL NOT (ch IN ['0'..'9','A'..'Z','_']);
	END (*READIDENTIFIER*);

    BEGIN (*READSCALAR*)
    IF direct_call THEN skip(source_file);
    readidentifier;
    IF NOT error_exit THEN
	BEGIN
	source_value := min_value;
	WHILE (scalar_name↑[-source_value] <> identifier) AND NOT error_exit DO
	    IF source_value < max_value THEN source_value := source_value+1
	    ELSE
		BEGIN
		error(undefined,declared_form);
		writeln(tty,' ',scalar_name↑[-min_value],'..',
			scalar_name↑[-max_value],' ***',identifier,'***');
		write(tty,' ':7);
		END;
	END;
    IF direct_call AND error_exit THEN
	BEGIN
	writefilename(source_file);
	stop
	END
    ELSE
	direct_call := true
    END (*READSCALAR*);

PROCEDURE readset( VAR source_file: text;
		  VAR set_variable: standard_set;
		  min_value, max_value: integer;
		  scalar_name: vector;
		  element_form: scalar_form);

    LABEL
	111;

    VAR
	scalar_value: RECORD
			  CASE scalar_form OF
			       integer_form: (ival: integer);
			       char_form   : (cval: char)
		      END;
	i, first_scalar: integer;
	subrange: boolean;

    BEGIN (*READSET*)
    set_flag := true;
    subrange := false;
    first_scalar := 0;
    set_variable := [];
    skip(source_file);
    IF max_value = 0 THEN max_value := maxset;
    IF NOT eof(source_file) THEN
	BEGIN
	IF ch = '[' THEN
	    BEGIN
	    nextch(source_file);
	    skip(source_file);
	    IF ch <> ']' THEN
		LOOP
		    direct_call := false;
		    CASE element_form OF
			integer_form:
				   readirange(source_file,scalar_value.ival,min_value,max_value);
			char_form:
				BEGIN
				IF ch <> '''' THEN
				    BEGIN
				    error(openquote,char_form);
				    writeln(tty,'***',ch,'***');
				    write(tty,' ':7);
				    END
				ELSE
				    BEGIN
				    readcrange(source_file,scalar_value.cval,chr(min_value),chr(max_value));
				    IF scalar_value.cval = '''' THEN
					BEGIN
					nextch(source_file) ;
					IF ch <> '''' THEN
					    BEGIN
					    error(doublequote,char_form);
					    writeln(tty,'***''''',ch,'''***');
					    write(tty,' ':7);
					    END;
					END ;
				    nextch(source_file);
				    IF NOT error_exit THEN
					IF ch <> '''' THEN
					    BEGIN
					    error(closequote,char_form);
					    write(tty,'***''',scalar_value.cval);
					    IF scalar_value.cval = '''' THEN
						write(tty,'''');
					    writeln(tty,ch,'***');
					    write(tty,' ':7);
					    END
					ELSE nextch(source_file);
				    scalar_value.ival := scalar_value.ival-offset;
				    END
				END;
			declared_form:
				    readscalar(source_file,scalar_value.ival,min_value,max_value,scalar_name)
			END (*CASE ELEMENT_FORM*);
		    IF NOT error_exit THEN
			BEGIN
			IF scalar_value.ival IN set_variable THEN
			    BEGIN
			    error(doublydef,element_form); write(tty,' ***');
			    CASE element_form OF
				integer_form:
					   write(tty,scalar_value.ival);
				char_form:
					BEGIN
					IF scalar_value.ival + offset = ord('''') THEN write(tty,'''') ;
					write(tty,'''',chr(scalar_value.ival+offset),'''');
					END ;
				declared_form:
					    write(tty,identifier)
				END;
			    writeln(tty,'***');
			    write(tty,' ':7);
			    END
			ELSE  (*NOT(SCALAR_VALUE.IVAL IN SET_VARIABLE)*)
			    IF subrange THEN
				FOR i := first_scalar+1 TO scalar_value.ival DO
				    set_variable := set_variable + [ i ]
			    ELSE
				set_variable := set_variable + [ scalar_value.ival ];
			IF (ch = ' ') THEN skip(source_file)
			END;
		    subrange := false;
		EXIT IF NOT (ch IN [',','.',':']) OR error_exit;
		    IF ch IN ['.',':'] THEN
			BEGIN
			IF ch = '.' THEN
			    BEGIN
			    nextch(source_file);
			    IF ch <> '.' THEN
				BEGIN
				error(twoperiods,element_form);
				writeln(tty,'***.',ch,'***');
				write(tty,'        ');
				GOTO 111
				END
			    END;
			subrange := true;
			first_scalar := scalar_value.ival
			END;
		    nextch(source_file);
		    skip(source_file);
		    END (*LOOP*);
    111:
	    direct_call := true;
	    IF NOT error_exit THEN
		IF (ch <> ']') THEN
		    BEGIN
		    error(closebracket,element_form);
		    writeln(tty,'***',ch,'***');
		    write(tty,' ':7);
		    END
		else
		    nextch(source_file);
	    END
	ELSE    (*CH <> '['*)
	    BEGIN
	    error(openbracket,element_form);
	    writeln(tty,'***',ch,'***');
	    write(tty,' ':7);
	    END;
	IF error_exit AND eof(source_file) THEN
	    error(endoffile,element_form);
	END
    ELSE  (* EOF(SOURCE_FILE) *)
	error(endoffile,element_form);
    set_flag := false;
    END (*READSET*);
	(** READISET READCSET READDSET **)

PROCEDURE readiset( VAR source_file: text;
		   VAR set_variable: standard_set;
		   min_value, max_value: integer);
    BEGIN (*READISET*)
    readset(source_file,set_variable,min_value,max_value,NIL,integer_form);
    IF error_exit THEN
	BEGIN
	writefilename(source_file);
	stop
	END
    END (*READISET*);

PROCEDURE readcset( VAR source_file: text;
		   VAR set_variable: standard_set;
		   min_value, max_value: integer);
    BEGIN (*READCSET*)
    readset(source_file,set_variable,min_value,max_value,NIL,char_form);
    IF error_exit THEN
	BEGIN
	writefilename(source_file);
	stop
	END
    END (*READCSET*);

PROCEDURE readdset( VAR source_file: text;
		   VAR set_variable: standard_set;
		   min_value, max_value: integer;
		   scalar_name: vector);
    BEGIN (*READDSET*)
    readset(source_file,set_variable,min_value,max_value,scalar_name,declared_form);
    IF error_exit THEN
	BEGIN
	writefilename(source_file);
	stop
	END
    END (*READDSET*);

    (**********************************************************************
     *
     *       PROCEDURE READSTR
     *
     *       - READS A STRING S FROM THE FILE STRINP.
     *          THE STRING STARTS IN THE CURRENT CHARACTER, AND ENDS
     *          WHEN A CRLF IS FOUND. IF THERE ARE MORE THAN 135
     *          CHARACTERS BEFORE THE CRLF, THEY ARE FLUSHED.
     *          AN ERROR MESSAGE IS ISUED, BUT EXECUTION CONTINUES.
     *
     *       READSTR IS PART OF THE PASREL RUNTIME-SUPPORT.
     *          A CALL TO READSTR IS GENERATED EACH TIME A VARIABLE OF
     *          THE NON-STANDARD TYPE STRING IS FOUND AS A PARAMETER TO
     *          PROCEDURES READ OR READLN.
     *
     *********************************************************************)

PROCEDURE readstr(VAR source_file: text; VAR string_variable: string);
    VAR
	ch: char;

    BEGIN (*READSTR*)
    IF eoln(source_file) THEN
	BEGIN
	readln(source_file);
	ch := source_file↑;
	END;
    WITH string_variable DO
	BEGIN
	len:=0;
	WHILE (NOT eoln(source_file)) AND (len < maxstrlen) DO
	    BEGIN
	    len:=len+1;
	    strtext[len]:=source_file↑;
	    get (source_file);
	    END;
	END;

    IF NOT eoln(source_file) THEN       (* DISCARD EXCEEDING CHARS *)
	BEGIN
	error(toolongstr,sstring_form);
	writeln(tty,maxstrlen:4,' CHARACTERS. REST OF LINE FLUSHED. EXECUTION CONTINUED');
	write(tty,'***':11);
	WHILE NOT eoln (source_file) DO
	    BEGIN
	    write(tty,source_file↑);
	    get(source_file);
	    END;
	write(tty,'***');
	break(tty);
	writefilename(source_file);
	END;
    END (*  READSTR *);

BEGIN
END.

PROGRAM write, wrtscalar, wrtiset, wrtcset, wrtdset;

    (************************************************************************************
     *
     *  (C) COPYRIGHT 1978, 1979
     *          BOARD OF TRUSTEES
     *          LELAND STANFORD JUNIOR UNIVERSITY
     *              STANFORD, CA. 94305, U. S. A.
     *
     *      (C) COPYRIGHT 1978, 1979
     *          ARMANDO R. RODRIGUEZ
     *              LOTS COMPUTER FACILITY
     *              STANFORD UNIVERSITY
     *              STANFORD, CA. 94305, U. S. A.
     *
     *   (C) COPYRIGHT H.-H. NAGEL
     *                 INSTITUT FUER INFORMATIK
     *                 DER UNIVERSITAET HAMBURG
     *                 SCHLUETERSTRASSE 70
     *                 2000 HAMBURG 13
     *                 GERMANY
     *                 1976
     *
     *   PASCAL RUNTIME SYSTEM (29-JUL-76,KISICKI)
     *
     *   EXTENDED FORMATTED OUTPUT
     *
     *      - WRTSCALAR    :  WRITE IDENTIFIERS OF DECLARED SCALARS
     *
     *      - WRTISET,
     *        WRTCSET,
     *        WRTDSET      :  WRITE SETS OF INTEGER, CHAR OR DECLARED SCALARS
     *                        OR THEIR SUBRANGES
     *
     ************************************************************************************)

CONST
    maxset = 71;
    offset = 40B;
    halfword = 777777B;
    intstdlgth = 12;

TYPE
    halfrange = 0..halfword;
    setrange = 0..maxset;
    vector = ↑name_vector;
    name_vector = ARRAY[0..0] OF alfa;
    standard_set = SET OF setrange;
    scalar_form = (integer_form,char_form,real_form,bool_form,declared_form);
    pair = PACKED RECORD
		      value: halfrange;
		      length: halfrange
		  END;

VAR
    direct_call: boolean;

INITPROCEDURE;
    BEGIN
    direct_call := true
    END;
	(** WRTSCALAR WRTSET WRTISET WRTCSET WRTDSET **)

PROCEDURE wrtscalar( VAR target_file: text;
		    scalar_value: integer;
		    maximum: pair;
		    scalar_name: vector);
    VAR
	i: integer;

    BEGIN
    IF (scalar_value >= 0) AND (scalar_value <= maximum.value) THEN
	WITH maximum DO
	    BEGIN
	    IF length=0 THEN length:=10 (*DEFAULT FORMAT*);
	    i := 0;
	    WHILE scalar_name↑[-scalar_value,i+1] <> ' ' DO i := i + 1;
	    IF length < i THEN write(target_file,scalar_name↑[-scalar_value]:length)
	    ELSE BEGIN
		write(target_file,' ':(length-i));
		write(target_file,scalar_name↑[-scalar_value]:i)
		END
	    END
    ELSE
	write(target_file,'**********');
    direct_call := true
    END;

PROCEDURE wrtset( VAR target_file: text;
		 set_value: standard_set;
		 maximum: pair;
		 scalar_name: vector;
		 element_form: scalar_form);
    VAR
	element: setrange;
	first_element, subrange: boolean;

    BEGIN
    write(target_file,'[');
    first_element := true;
    subrange := false;
    element := 0;
    WHILE element <= maxset DO
	BEGIN
	IF element IN set_value THEN
	    BEGIN
	    IF NOT (first_element OR subrange) THEN write(target_file,',');
	    first_element := false;
	    subrange := false;
	    direct_call := false;
	    WITH maximum DO
		CASE element_form OF
		    integer_form:
			       BEGIN
			       IF length <= 0 THEN length := intstdlgth;
			       write(target_file,element:length)
			       END;
		    char_form:
			    BEGIN
			    IF length > 3 THEN
				IF (element + offset) = ord('''') THEN write(target_file,' ':(length-4),'''')
				ELSE write(target_file,' ':(length-3));
			    write(target_file,'''',chr(element+offset),'''')
			    END;
		    declared_form:
				wrtscalar(target_file,element,maximum,scalar_name)
		    END;
	    IF (element+1 IN set_value) AND (element+2 IN set_value) THEN
		BEGIN
		WHILE element+2 IN set_value DO
		    element := element + 1;
		subrange := true;
		write(target_file,'..')
		END
	    END;
	element := element + 1
	END;
    write(target_file,']');
    direct_call := true
    END;

PROCEDURE wrtiset( VAR target_file: text;
		  set_value: standard_set;
		  maximum: pair);
    BEGIN
    wrtset(target_file,set_value,maximum,NIL,integer_form)
    END;

PROCEDURE wrtcset( VAR target_file: text;
		  set_value: standard_set;
		  maximum: pair);
    BEGIN
    wrtset(target_file,set_value,maximum,NIL,char_form)
    END;

PROCEDURE wrtdset( VAR target_file: text;
		  set_value: standard_set;
		  maximum: pair;
		  scalar_name: vector);
    BEGIN
    wrtset(target_file,set_value,maximum,scalar_name,declared_form)
    END;

BEGIN
END.

PROGRAM timing, setruntime, setelapsedtime, settime, runtime, elapsedtime,
    timereport;

    (*******************************************************************
     *
     *  (C) COPYRIGHT 1978, 1979
     *          BOARD OF TRUSTEES
     *          LELAND STANFORD JUNIOR UNIVERSITY
     *              STANFORD, CA. 94305, U. S. A.
     *
     *      (C) COPYRIGHT 1978, 1979
     *          ARMANDO R. RODRIGUEZ
     *              LOTS COMPUTER FACILITY
     *              STANFORD UNIVERSITY
     *              STANFORD, CA. 94305, U. S. A.
     *
     *      PACKAGE OF PROCEDURES TO KEEP AND REPORT RUNTIME AND ELAPSED
     *      TIME. THE TIME PERIOD THAT THEY REPORT IS THAT TRANSCURRED
     *      BETWEEN THE CALLS TO SETRUNTIME AND RUNTIME (CORR SETELAPSEDTIME
     *      AND ELAPSEDTIME) OR BETWEEN TWO CALLS TO RUNTIME (CORR ELAPSEDTIME)
     *
     *********************************************************************)

VAR
    cputime : ARRAY[0..3] OF integer;
    clocktime : ARRAY[0..4] OF integer;
    ttyout: text;

PROCEDURE setruntime;
    BEGIN (* SETRUNTIME *)
    cputime[0] := clock;
    END (* SETRUNTIME *);

PROCEDURE setelapsedtime;
    BEGIN (* SETELAPSEDTIME *)
    clocktime[0] := realtime;
    END (* SETELAPSEDTIME *);

PROCEDURE settime;
    BEGIN (* SETTIME *)
    setruntime;
    setelapsedtime;
    END (* SETTIME *);

PROCEDURE runtime (VAR buffer: alfa);
    (* RETURNS THE TRANSCURRED CPUTIME IN THE FORMAT 'MM:SS:MMM ' *)

    VAR
	temptime, j, i: integer;

    BEGIN (* RUNTIME *)
    temptime := clock;

    cputime[0] := temptime - cputime[0];
    cputime[1] := cputime[0] DIV 60000;
    cputime[2] := (cputime[0] MOD 60000) DIV 1000;
    cputime[3] := cputime[0] MOD 1000;
    cputime[0] := temptime;

    buffer := '  :  .    ';
    buffer[7] := chr(cputime[3] DIV 100 + ord ('0'));
    j := 1;

    FOR i := 1 TO 3 DO
	BEGIN
	buffer[j] := chr((cputime[i] MOD 100)DIV 10 + ord('0'));
	buffer[j + 1] := chr(cputime[i] MOD 10 + ord('0'));
	j := j + 3 + j DIV 4;
	END;
    END (* RUNTIME *);

PROCEDURE elapsedtime (VAR buffer: alfa);
    (* RETURNS THE ELAPSED TIME IN THE FORMAT 'HH:MM:SS.D' *)

    VAR
	temptime, i, j: integer;

    BEGIN (* ELAPSEDTIME *)
    temptime := realtime;

    clocktime[0] := temptime - clocktime[0];
    clocktime[1] := clocktime[0] DIV 3600000;
    clocktime[2] := (clocktime[0] MOD 3600000) DIV 60000;
    clocktime[3] := (clocktime[0] MOD 60000) DIV 1000;
    clocktime[4] := (clocktime[0] MOD 1000) DIV 100
    + (clocktime[0] MOD 100) DIV 50;
    IF clocktime[4] = 10 THEN
	BEGIN
	clocktime[3] := clocktime[3] + 1;
	clocktime[4] := 0;
	END;
    clocktime[0] := temptime;

    buffer := '  :  :  . ';
    j := 1;

    FOR i := 1 TO 3 DO
	BEGIN
	buffer[j] := chr(clocktime[i] DIV 10 + ord('0'));
	buffer[j + 1] := chr(clocktime[i] MOD 10 + ord('0'));
	j := j + 3;
	END;

    buffer[10] := chr(clocktime[4] MOD 10 + ord('0'));
    END (* ELAPSEDTIME *);

PROCEDURE timereport (VAR ttyout: text; header: alfa);
    (* WRITES ONTO FILE TTYOUT THE CPU AND ELAPSED TIME *)

    VAR
	buffer1, buffer2 : alfa;

    BEGIN (* TIMEREPORT *)
    runtime (buffer1);
    elapsedtime (buffer2);
    writeln(ttyout);
    IF header <> '          ' THEN
	write(ttyout,header,' ');
    writeln(ttyout,'RUNTIME: ',buffer1,'     ELAPSED: ',buffer2);
    break(ttyout);
    END (* TIMEREPORT *);

BEGIN
END.

PROGRAM strings, assign, length, pos, substr, concat, getchar, putchar,
    strlt, strle, streq, strge, strgt, strne, wrtstr, wrtst1;

    (**********************************************************************
     *
     *  (C) COPYRIGHT 1978, 1979
     *          BOARD OF TRUSTEES
     *          LELAND STANFORD JUNIOR UNIVERSITY
     *              STANFORD, CA. 94305, U. S. A.
     *
     *      (C) COPYRIGHT 1978, 1979
     *          ARMANDO R. RODRIGUEZ
     *              LOTS COMPUTER FACILITY
     *              STANFORD UNIVERSITY
     *              STANFORD, CA. 94305, U. S. A.
     *
     *      PASCAL NON-STANDARD STRING PACKAGE (14-SEPT-78)
     *
     *      A PACKAGE OF SUBROUTINES TO SUPPORT VARIABLE-LENGTH STRING
     *        VARIABLES IN PASCAL. THEIR CALLING DOES NOT FOLLOW THE
     *        STANDARD TYPE-CHECKING RESTRICTIONS IN PASCAL. THE COMPILER
     *        NEEDS TO KNOW ABOUT THEM AND TREAT THEIR PARAMETERS IN A
     *        SPECIAL WAY.
     *
     *        -  ASSIGN     CREATE A STRING
     *
     *        -  LENGTH, POS        RETURN INFORMATION ON THE STRING
     *
     *        -  SUBSTR, CONCAT,
     *           GETCHAR, PUTCHAR   MOVE AROUND PARTS OF STRINGS
     *
     *        -  STRLT, STRLE, STREQ,
     *           STRGE, STRGT, STRNE        COMPARE TWO STRINGS
     *
     *        -  WRTSTR, WRTST1     WRITE A STRING
     *
     *        -  READSTR            READ THE REST OF THE LINE AS A STRING.
     *                              IT IS WITH THE OTHER READ PROCEDURES.
     *
     *       N. B.: SUBSTR, GETCHAR AND PUTCHAR CONTAIN CODE FOR BOUNDARY
     *              CHECKING OF THE START POSITION, WHICH WILL BE SUPERFLUOUS
     *              WHEN CHECKING FOR PARAMETER PASSING IS IMPLEMENTED.
     *
     *********************************************************************)

CONST
    maxstrlen = 135;
    checkstrlen = 137;
TYPE
    strgrange = 1..maxstrlen;
    strgrange0 = 0..maxstrlen;
    string = RECORD
		 strtext: PACKED ARRAY [1..maxstrlen] OF char;
		 len: strgrange0;
	     END;

    strgrangeneg = 0..checkstrlen;
    error_form = (outofrange, outofstring);
    var_form   = (src_var, dest_var, final_pos);
    pack7      = PACKED ARRAY[1..7] OF char;
VAR
    error_exit: boolean;
    errormessage: PACKED ARRAY[var_form,1..26] OF char;
    direct_call: boolean;
    procname: pack7;

INITPROCEDURE;
    BEGIN
    error_exit := false;        direct_call := true;
    errormessage[src_var]   := 'START SOURCE POSITION     ';
    errormessage[dest_var]  := 'START DESTINATION POSITION';
    errormessage[final_pos] := 'FINAL DESTINATION POSITION';
    END;

PROCEDURE stop; EXTERN;

PROCEDURE errinstr(errornumber: error_form; problemvar: var_form;
		   value, limit: integer);
    BEGIN (*ERRINSTR*)
    IF errornumber = outofrange THEN
	write(tty,'        OUT OF THE VALID RANGE 1..')
    ELSE
	BEGIN
	write(tty,'        GREATER THAN STRING LENGTH ');
	IF problemvar = dest_var THEN
	    write(tty,'+ 1,');
	END;
    writeln(tty,limit:4,' ***',value,'***');
    write(tty,'        WHEN CALLING ',procname,' ');
    break(tty);
    error_exit := true;
    END (*ERRINSTR*);

PROCEDURE checklength(VAR here: string; VAR length: strgrangeneg);
    VAR
	kludge : PACKED RECORD
			    CASE boolean OF
				 true: (str: string);
				 false: (bit: PACKED ARRAY[0..35] OF 0..1);
			END;
	i: 0..35;

    BEGIN (*CHECKLENGTH*)
    IF length = checkstrlen THEN
	BEGIN
	kludge.str := here;
	FOR i := 0 TO 6 DO
	    kludge.bit[i] := kludge.bit[i + 29];
	here := kludge.str;
	length := 1
	END
    ELSE
	IF length > maxstrlen THEN
	    length := here.len;
    END (*CHECKLENGTH*);

    (**********************************************************************
     *
     *      PROCEDURE ASSIGN
     *
     *   - ASSIGNS THE STRING DEST FROM THE PACKED ARRAY OF CHAR SRC.
     *        THE COMPILER WILL ALLOW SRC TO BE OF ANY LENGTH.
     *
     *      ASSIGN IS A PRE-DECLARED PROCEDURE
     *      AVAILABLE TO EVERY PASCAL USER.
     *
     *********************************************************************)

PROCEDURE assign(src: string; VAR dest: string; srclen: strgrange0);
    VAR
	i: integer;
    BEGIN (* ASSIGN *)
    checklength(src,srclen);
    dest.len:=srclen;
    FOR i:=1 TO srclen DO dest.strtext[i]:=src.strtext[i];
    END (* ASSIGN *);

    (**********************************************************************
     *
     *      FUNCTION LENGTH
     *
     *   - RETURNS THE LENGTH OF THE STRING SRC
     *
     *      LENGTH IS A PRE-DECLARED PROCEDURE
     *      AVAILABLE TO EVERY PASCAL USER.
     *
     *********************************************************************)

FUNCTION length(src: string; srclen: strgrangeneg): strgrange0;
    BEGIN (* LENGTH *)
    checklength(src, srclen);
    length:=srclen;
    END (*  LENGTH *);

    (**********************************************************************
     *
     *      FUNCTION POS
     *
     *      - RETURNS THE STARTING POSITION OF THE FIRST OCCURRENCE OF THE
     *        STRING S1 IN THE STRING S2. IF THERE IS NO OCURRENCE, 0 IS
     *        RETURNED.
     *
     *      POS IS A PRE-DECLARED FUNCTION
     *      AVAILABLE TO EVERY PASCAL USER.
     *
     *********************************************************************)

FUNCTION pos(s1, s2: string; s1len,s2len: strgrangeneg): strgrange0;
    VAR
	i, j, k, ind: integer;
	matching: boolean;

    BEGIN (* POS *)
    ind:=0;
    i := 1;
    checklength(s1,s1len);
    checklength(s2,s2len);
    WHILE (i <= s2len - s1len + 1) AND (ind = 0) DO
	BEGIN
	k := i;
	j := 1;
	matching := true;
	WHILE (j <= s1len) AND matching DO
	    IF s2.strtext[k] = s1.strtext[j] THEN
		BEGIN
		j := j + 1;
		k := k + 1;
		END
	    ELSE
		matching := false;
	IF matching THEN
	    ind := i
	ELSE
	    i := i + 1;
	END;
    pos := ind;
    END (* POS *);

    (**********************************************************************
     *
     *      PROCEDURE SUBSTR
     *
     *      - COPIES AT MOST LENG CHARACTERS FROM STRING SRC TO STRING DEST,
     *        STARTING AT POSITION SRCPOS IN SRC, DESTPOS IN DEST. DEST.LEN
     *        WILL BE CHANGED IF NEEDED. IF SRCPOS + LENG IS TOO LONG,
     *        ONLY (SRC.LEN - SRCPOS + 1) CHARACTERS WILL BE COPIED.
     *        IF DESTPOS + LENG - 1 > MAXSTRLEN, ERROR.
     *        IF SRCPOS OR DESTPOS IS OUTSIDE THE STRING, ERROR.
     *
     *      SUBSTR IS A PRE-DECLARED PROCEDURE
     *      AVAILABLE TO EVERY PASCAL USER.
     *
     *********************************************************************)

PROCEDURE substr(src: string; VAR dest: string;
		 srcpos, destpos, leng: strgrange; srclen: strgrangeneg);
    VAR
	idest, isrc, netsrcleng, destlast, lastlast: integer;

    BEGIN (*SUBSTR*)

    IF leng > 0 THEN
	BEGIN
	IF direct_call THEN
	    procname := 'SUBSTR ';
	checklength(src,srclen);
	IF (srcpos < 1) OR (srcpos > maxstrlen) THEN
	    errinstr(outofrange,src_var,srcpos,maxstrlen)
	ELSE
	    IF (destpos < 1) OR (destpos > maxstrlen) THEN
		errinstr(outofrange,dest_var,destpos,maxstrlen)
	    ELSE
		IF srcpos > srclen THEN
		    errinstr(outofstring,src_var,srcpos,srclen)
		ELSE
		    IF destpos > dest.len + 1 THEN
			errinstr(outofstring,dest_var,destpos,dest.len + 1)
		    ELSE
			IF (destpos + leng - 1) > maxstrlen THEN
			    errinstr(outofstring,final_pos,destpos+srclen-1,maxstrlen);
	IF error_exit THEN
	    IF direct_call THEN
		BEGIN
		error_exit := false;
		stop
		END
	    ELSE
	ELSE    (* NO BOUNDS ERRORS *)
	    BEGIN
	    netsrcleng := min (leng, srclen + 1 - srcpos);
	    destlast := destpos + netsrcleng - 1;
	    isrc := srcpos;
	    FOR idest := destpos TO destlast DO
		BEGIN
		dest.strtext[idest] := src.strtext[isrc];
		isrc := isrc + 1;
		END;
	    IF destlast > dest.len THEN
		dest.len := destlast;
	    END
	END
    END (* SUBSTR*);

    (**********************************************************************
     *
     *       PROCEDURE CONCAT
     *
     *       - COPIES STRING S1 TO THE END OF STRING S2
     *         S1 IS NOT AFFECTED
     *
     *      CONCAT IS A PREDEFINED PROCEDURE
     *      AVAILABLE TO EVERY PASCAL USER.
     *********************************************************************)

PROCEDURE concat (src: string; VAR dest: string; srclen: strgrangeneg);
    BEGIN (*CONCAT*)
    direct_call := false;
    procname := 'CONCAT ';
    checklength(src,srclen);
    substr(src,dest,1,dest.len+1,srclen,srclen);

    IF error_exit THEN
	BEGIN
	direct_call := true;
	error_exit := false;
	stop
	END;
    END (*CONCAT*);


    (**********************************************************************
     *
     *      FUNCTION GETCHAR
     *
     *      - RETURN THE CHARACTER CONTAINED IN POSITION SRCPOS OF STRING SRC.
     *        IF SRCPOS FALLS OUT OF THE VALID STRING, ERRINSTR.
     *
     *      GETCHAR IS A PRE-DECLARED FUNCTION
     *      AVAILABLE TO EVERY PASCAL USER.
     *
     *********************************************************************)

FUNCTION getchar (src: string; srcpos: strgrange; srclen: strgrangeneg): char;
    VAR
	ch: char;

    BEGIN (* GETCHAR *)
    procname := 'GETCHAR';
    checklength(src,srclen);
    IF (srcpos < 1) OR (srcpos > maxstrlen) THEN
	errinstr(outofrange,src_var,srcpos,maxstrlen)
    ELSE
	IF srcpos > srclen THEN
	    errinstr(outofstring,src_var,srcpos,srclen);
    IF error_exit THEN
	BEGIN
	error_exit := false;
	stop
	END
    ELSE
	getchar := src.strtext[srcpos];
    END (* GETCHAR *);

    (**********************************************************************
     *
     *      PROCEDURE PUTCHAR
     *
     *      - PUTS THE CHARACTER SRC AT POSITION DESTPOS IN STRING DEST.
     *        IF DESTPOS > DEST.LEN, ERROR
     *
     *      PUTCHAR IS A PRE-DECLARED PROCEDURE
     *      AVAILABLE TO EVERY PASCAL USER.
     *
     *********************************************************************)

PROCEDURE putchar (src: char; VAR dest: string; destpos: strgrange);
    BEGIN (* PUTCHAR *)
    procname := 'PUTCHAR';
    IF (destpos < 1) OR (destpos > maxstrlen) THEN
	errinstr(outofrange,dest_var,destpos,maxstrlen)
    ELSE
	IF destpos > dest.len + 1 THEN
	    errinstr(outofstring,dest_var,destpos,dest.len + 1);
    IF error_exit THEN
	BEGIN
	error_exit := false;
	stop;
	END
    ELSE
	BEGIN
	dest.strtext[destpos] := src;
	IF destpos > dest.len THEN
	    dest.len := destpos;
	END
    END (* PUTCHAR *);

    (**********************************************************************
     *
     *      FUNCTIONS TO COMPARE STRINGS: STRLT, STRLE, STREQ,
     *                                    STRGE, STRGT, STRNE
     *
     *      - EACH ONE RETURNS THE RESULT OF THE COMPARISON OF STRINGS
     *        S1 AND S2, ACCORDING TO THE LAST TWO LETTERS OF ITS NAME.
     *
     *          A STRING S1 IS EQUAL TO S2 IF
     *              1. THEY ARE OF THE SAME LENGTH, AND
     *              2. THEIR CHARACTERS ARE EQUAL IN EVERY POSITION.
     *
     *          A STRING S1 IS GREATER THAN S2 IF
     *              1. THEIR CHARACTERS ARE EQUAL IN POSITIONS 1, ..., X-1
     *                   AND S1 HAS A CHARACTER GREATER IN THE COLLATING
     *                   SEQUENCE IN POSITION X, OR
     *              2. THEIR CHARACTERS ARE EQUAL IN POSITIONS 1, ...,
     *                   S2.LEN, AND S1.LEN > S2.LEN.
     *
     *      THEY ARE ALL PRE-DECLARED FUNCTIONS
     *      AVAILABLE TO EVERY PASCAL USER.
     *
     *********************************************************************)

FUNCTION strgt(s1, s2: string; s1len,s2len: strgrangeneg): boolean;
    VAR
	i, tmin: integer;
	answer: boolean;

    BEGIN (* STRGT *)
    checklength(s1,s1len);
    checklength(s2,s2len);
    tmin:= min(s1len, s2len);
    answer := false;
    i := 1;
    WHILE (i <= tmin) AND (s1.strtext[i] = s2.strtext[i]) DO
	i := i + 1;
    IF i <= s1len THEN
	IF i <= s2len THEN
	    answer := s1.strtext[i] > s2.strtext[i]
	ELSE
	    answer := true;
    strgt := answer;
    END  (* STRGT *);

FUNCTION strge(s1, s2: string; s1len,s2len: strgrangeneg): boolean;
    BEGIN (*STRGE*)
    strge := NOT strgt(s2, s1, s2len, s1len);
    END (*STRGE*);

FUNCTION streq(s1, s2: string; s1len,s2len: strgrangeneg): boolean;
    VAR
	i, tmin: integer;
	answer: boolean;

    BEGIN (* STREQ *)
    checklength(s1,s1len);
    checklength(s2,s2len);
    IF s1len <> s2len THEN
	answer := false
    ELSE
	BEGIN
	answer := true;
	i := 1;
	WHILE (i <= s1len) AND answer DO
	    BEGIN
	    IF s1.strtext[i] <> s2.strtext[i] THEN
		answer := false;
	    i := i + 1;
	    END;
	END;
    streq := answer;
    END  (* STREQ *);

FUNCTION strle(s1, s2: string; s1len,s2len: strgrangeneg): boolean;
    BEGIN (*STRLE*)
    strle := NOT strgt(s1, s2, s1len, s2len);
    END (*STRLE*);

FUNCTION strlt(s1, s2: string; s1len,s2len: strgrangeneg): boolean;
    BEGIN (*STRLT*)
    strlt := strgt(s2, s1, s2len, s1len);
    END (*STRLT*);

FUNCTION strne(s1, s2: string; s1len,s2len: strgrangeneg): boolean;
    BEGIN (*STRNE*)
    strne := NOT streq(s1, s2, s1len, s2len);
    END (*STRNE*);

PROCEDURE wrtstr(VAR dest_file:text; src: string; totallength: integer);
    BEGIN (*WRTSTR*)
    write(dest_file,src.strtext:totallength);
    END (*WRTSTR*);

PROCEDURE wrtst1(VAR dest_file:text; src: string; totallength: integer);
    BEGIN (*WRTST1*)
    write(dest_file,src.strtext:src.len);
    END (*WRTST1*);

BEGIN
END.

PROGRAM dumper, dpcnts;
    (**********************************************************************
     *
     *  (C) COPYRIGHT  1979
     *          BOARD OF TRUSTEES
     *          LELAND STANFORD JUNIOR UNIVERSITY
     *              STANFORD, CA. 94305, U. S. A.
     *
     *      (C) COPYRIGHT 1979,
     *          ARMANDO R. RODRIGUEZ
     *              LOTS COMPUTER FACILITY
     *              STANFORD UNIVERSITY
     *              STANFORD, CA. 94305, U. S. A.
     *
     *      AUXILIARY ROUTINES FOR STATEMENT COUNTS (PROFILE)
     *      AS IMPLEMENTED BY PHILIP WISOFF, FEB-79
     *
     *      DPCNTS:
     *              DUMPS TO A FILE OF INTEGER THE LINE/PAGE MARKERS AND
     *              THE COUNTS FOR EACH BASIC BLOCK.
     *
     *********************************************************************)

TYPE
    dfiletype = FILE OF integer;
    packed9 = PACKED ARRAY [1..9] OF char;
VAR
    dumpfile : dfiletype;

PROCEDURE dpcnts (filename : packed9;startofcounts,endofcounts : integer);

    TYPE
	linerange = 1..777777B;
	pointer = RECORD
		      CASE boolean OF
			   true : (location : ↑data);
			   false : (incloc : linerange);
		  END;
	data = PACKED RECORD
			  page,line : linerange;
			  count : integer;
		      END;
    VAR
	dataptr : pointer;
	countdata : data;
    BEGIN (*DPCNTS*)
    rewrite(dumpfile,filename);             (*OPEN THE FILE*)
    WITH dataptr DO BEGIN
	dataptr.incloc := startofcounts;
	WHILE dataptr.incloc <= endofcounts DO  (*FOR EACH COUNT MARKER*)
	    BEGIN
	    WITH dataptr DO BEGIN           (*DUMP LINE, PAGE AND COUNT*)
		dumpfile↑ := location↑.page;
		put(dumpfile);
		dumpfile↑ := location↑.line;
		put(dumpfile);
		dumpfile↑ := location↑.count;
		put(dumpfile);
		END;
	    dataptr.incloc := dataptr.incloc + 2;   (*AND GO TO THE NEXT*)
	    END;
	END;
    reset(dumpfile,filename);                       (*CLOSE THE FILE*)
    %3 message('to produce the profile listing, .r pcref');	\
    call('pcref dmp');
    END;
BEGIN
END.

PROGRAM mathruns, psqrt;
    (**********************************************************************
     *
     *  (C) COPYRIGHT  1979
     *          BOARD OF TRUSTEES
     *          LELAND STANFORD JUNIOR UNIVERSITY
     *              STANFORD, CA. 94305, U. S. A.
     *
     *      (C) COPYRIGHT 1979,
     *          ARMANDO R. RODRIGUEZ
     *              LOTS COMPUTER FACILITY
     *              STANFORD UNIVERSITY
     *              STANFORD, CA. 94305, U. S. A.
     *
     *      MATHEMATICALLY-ORIENTED RUNTIMES FOR THE PASCAL COMPILER.
     *
     *      PSQRT:
     *              CHECKS FOR THE PARAMETER TO THE FORTRAN ROUTINE FOR
     *              SQRT TO BE A POSITIVE REAL NUMBER.
     *
     *********************************************************************)


PROCEDURE stop; EXTERN;

FUNCTION sqrt(fvalue:real): real; FORTRAN;

FUNCTION psqrt(fvalue: real): real;
    BEGIN (*PSQRT*)
    IF fvalue < 0 THEN
	BEGIN
	writeln(tty);
	writeln(tty,'%?      VALUE ERROR: ATTEMPT TO OBTAIN THE SQUARE ROOT OF A NEGATIVE NUMBER');
	writeln(tty,'%?      VALUE PASED: ',fvalue);
	write(tty,'%?     ');
	break(tty);
	stop;
	END
    ELSE
	psqrt := sqrt(fvalue);
    END (*PSQRT*);

BEGIN
END.